perm filename COMPLR[LSP,WD]1 blob
sn#010447 filedate 1972-08-16 generic text, type T, neo UTF8
(PROG (SEXPR IBASE)
(SETQ IBASE (ADD1 7))
LOOP (SETQ SEXPR (ERRSET (READ)))
(COND ((EQ SEXPR (QUOTE $EOF$)) (RETURN NIL)))
(COND ((MEMQ (CAAR SEXPR) (QUOTE (BEGINBLOCK ENDBLOCK)))
(GO LOOP)))
(PRINT (EVAL (CAR SEXPR)))
(GO LOOP))
(BEGINBLOCK COMPILER)
(DECLARE (SPECIAL LASTOUT LOCVARS SPECVARS P1CNT P2CNT FUNNAME)
(SPECIAL ALLVARS RENAMELIST INPROG P1SCNT P1SCV FOUNDFREE)
(SPECIAL LISTING MSGCHAN INDEV OUTDEV OUTEXT)
(SPECIAL ACS PDL PDLDEPTH MINDEPTH)
(SPECIAL LDLST PRGSPFLG PROGVARS SPLDLST CCLST RSL CTAG)
(SPECIAL PROGSW GOLIST VARLIST)
(SPECIAL GOLIST EXIT EXITN PRSSL PROGSW VGO PVR)
(SPECIAL NACS VALUEAC ALLACS GOTABAC FARGAC ARRAYAC)
(SPECIAL ALLFUNS GENFUNS UNDFUNS CODESIZE CONSTSIZE)
(SPECIAL LINCNT PAGEWIDTH PAGEHEIGHT)
(SPECIAL *SP *TB *CR *LF *VT *FF *CO *PT)
(SPECIAL *LP *RP *SL *AM *AT *RO *COLON)
(SPECIAL IBASE BASE *NOPOINT INUM0)
(SPECIAL TRACELIST SHOWNAMES))
(BEGINBLOCK MACROS)
(DEFPROP DEINITTAG (LAMBDA (L) (Q (DEINITSYM (Q TAG)))) MACRO)
(DEFPROP DEINITVAL (LAMBDA (L) (Q (DEINITSYM (Q VAL)))) MACRO)
(DEFPROP DEINITVAR (LAMBDA (L) (Q (DEINITSYM (Q VAR)))) MACRO)
(DEFPROP DFUNC
(LAMBDA (L)
(LIST (Q DEFPROP)
(CAADR L)
(MCONS (Q LAMBDA) (CDADR L) (CDDR L))
(Q EXPR)))
MACRO)
(DEFPROP FLUSHDEF (LAMBDA (L) (CONS (Q FLUSHEXPR) (CDR L))) MACRO)
(DEFPROP GENTAG (LAMBDA (L) (Q (NEXTSYM (Q TAG)))) MACRO)
(DEFPROP GENVAL (LAMBDA (L) (Q (NEXTSYM (Q VAL)))) MACRO)
(DEFPROP GENVAR (LAMBDA (L) (Q (NEXTSYM (Q VAR)))) MACRO)
(DEFPROP GETPROP (LAMBDA (L) (CONS (Q GET) (CDR L))) MACRO)
(DEFPROP IFIF
(LAMBDA (L)
(LIST (Q COND) (CDR L) (LIST T (CONS (Q NOT) (CDDR L)))))
MACRO)
(DEFPROP INCR
(LAMBDA (L)
(LIST (QUOTE SETQ) (CADR L) (LIST (QUOTE ADD1) (CADR L))))
MACRO)
(DEFPROP INITTAG (LAMBDA (L) (Q (INITSYM (Q TAG)))) MACRO)
(DEFPROP INITVAL (LAMBDA (L) (Q (INITSYM (Q VAL)))) MACRO)
(DEFPROP INITVAR (LAMBDA (L) (Q (INITSYM (Q VAR)))) MACRO)
(DEFPROP MAPDEF
(LAMBDA (L)
(LIST (Q MAPCAR)
(SUBST (CADR L)
(Q IND)
(Q (FUNCTION (LAMBDA (PAIR)
(PUTPROP (CAR PAIR)
(CADR PAIR)
(QUOTE IND))))))
(LIST (Q QUOTE) (CDDR L))))
MACRO)
(DEFPROP MCONS
(LAMBDA (L)
(COND ((NULL (CDDR L)) (CADR L))
(T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
MACRO)
(DEFPROP OUTINST (LAMBDA (INST) (CONS (Q OUTSTAT) (CDR INST))) MACRO)
(DEFPROP OUTPSOP (LAMBDA (PSOP) (CONS (Q OUTSTAT) (CDR PSOP))) MACRO)
(DEFPROP OUTTAG (LAMBDA (TAG) (CONS (Q OUTSTAT) (CDR TAG))) MACRO)
(DEFPROP PDLDEPTH (LAMBDA (L) (Q PDLDEPTH)) MACRO)
(DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO)
(DEFPROP TAGP (LAMBDA (L) (CONS (Q ATOM) (CDR L))) MACRO)
(DEFPROP USERWARN
(LAMBDA (L)
(LIST (Q PRINTMSG)
(LIST (Q APPEND)
(LIST (Q LIST) (CADR L))
(LIST (Q Q) (APPEND (CDDR L) (Q (IN))))
(Q (LIST (CURFUN))))))
MACRO)
(BEGINBLOCK PROPTABLE)
(DEFPROP FIRSTPROP (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)
(DEFPROP LASTPROP (LAMBDA (L) (CONS (Q NULL) (CDR L))) MACRO)
(DEFPROP NEXTPROP (LAMBDA (L) (CONS (Q CDDR) (CDR L))) MACRO)
(DEFPROP PROPNAM (LAMBDA (L) (CONS (Q CAR) (CDR L))) MACRO)
(DEFPROP PROPTABLE (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)
(DEFPROP PROPVAL (LAMBDA (L) (CONS (Q CADR) (CDR L))) MACRO)
(ENDBLOCK PROPTABLE)
(ENDBLOCK MACROS)
(BEGINBLOCK TOPLEVEL)
(DFUNC (ACTONEXPR XPR)
(PROG (ACTION)
(COND ((ATOM XPR) (GO FLUSH)))
(SETQ ACTION (GETGET (CAR XPR) (Q COMPEFFECT)))
(COND (ACTION ((PROPVAL ACTION) XPR) (RETURN NIL)))
FLUSH(FLUSHEXPR XPR)
(RETURN NIL)))
(DFUNC (ACTONMACRO XPR)
(ACTONEXPR ((GETPROP (CAR XPR) (Q MACRO)) XPR)))
(DEFPROP CMP
(LAMBDA (L)
(COND ((NULL L) NIL)
((NULL (CDR L)) (COMPILEFUN (CAR L)))
(T (PUTPROP (CAAR L)
(MCONS (Q LAMBDA) (CDAR L) (CDR L))
(COND ((NULL (CDDR L)) (Q EXPR)) (T (CADDR L))))
(COMPILEFUN (CAAR L)))))
FEXPR)
(DFUNC (COMPDEF DEFIN)
(PROG (ACTION)
(COND ((NOT (EQUAL (LENGTH DEFIN) 4))
(USERERR ARGNOERR-COMPDEF)))
(COND ((SETQ ACTION (SEEKPROP (CADDDR DEFIN) (Q DEFACTION)))
((PROPVAL ACTION) DEFIN)
(RETURN NIL)))
(FLUSHDEF DEFIN)
(RETURN NIL)))
(DFUNC (COMPFILE INFILE OUTFILE)
(PROG (ALLFUNS UNDFUNS GENFUNS CODESIZE CONSTSIZE STARTTIME)
(INITPROP (Q CURFILE) (Q NAME) INFILE)
(SETQ STARTTIME (TIME))
(SETQ CODESIZE (SETQ CONSTSIZE 0))
(DOFILE (FUNCTION COMPREADS) INFILE OUTFILE)
(TELLTALE (CADR INFILE) STARTTIME)
(DELETEPROP (Q CURFILE) (Q NAME))))
(DFUNC (COMPFUNC NAME EXPR FLAG)
(PROG (LOCVARS SPECVARS P1EXP P1CNT P2CNT LASTOUT)
(INITTAG)
(INITVAL)
(INITVAR)
(INITPROP (Q CURFUN) (Q NAME) NAME)
(INITPROP (Q SUBFUN) (Q SYMNO) 1)
(SETQ P1EXP (PASS1 EXPR))
(DELETEPROP (Q SUBFUN) (Q SYMNO))
(COND ((NOT (ATMARGIN)) (LINEF 2)))
(OUTPSOP (LIST (Q LAP) NAME FLAG))
(COND ((EQ (CAR EXPR) (Q FSUBR))
(COND ((NOT (NULL (CDADR EXPR)))
(OUTINST (Q (PUSHJ P *AMAKE))))))
((EQ (CAR EXPR) (Q LSUBR))
(OUTINST (Q (JSP 3 *LCALL)))
(INITPROP (Q ARG) (Q P2) (Q P2ARG))))
(PASS2 P1EXP)
(DELETEPROP (Q CURFUN) (Q NAME))
(COND ((EQ (CAR EXPR) (Q LSUBR)) (DELETEPROP (Q ARG) (Q P2))))
(COND ((NOT (EQUAL P2CNT P1CNT))
(PRINTMSG (LIST P1CNT P2CNT))
(COMPERR COUNTSDISAGREE-COMPFUNC)))
(DEINITTAG)
(DEINITVAL)
(DEINITVAR)
(RETURN NAME)))
(DEFPROP COMPILE
(LAMBDA (NAMES)
(PROG (DONE)
LOOP (COND ((NULL NAMES) (OUTC NIL T) (RETURN DONE)))
(COND ((NOT (ATOM (CAR NAMES)))
(OUTC (EVAL (CONS (Q OUTPUT) (CAR NAMES))) NIL))
(T (SETQ DONE (APPEND DONE (COMPILEFUN (CAR NAMES))))))
(SETQ NAMES (CDR NAMES))
(GO LOOP)))
FEXPR)
(DFUNC (COMPILEFUN NAME)
(PROG (GENFUNS UNDFUNS CODESIZE CONSTSIZE MSGCHAN SHOWNAMES PROP
DONE PLIST)
(SETQ CODESIZE (SETQ CONSTSIZE 0))
(SETQ PLIST (CDR NAME))
LOOP (COND ((NULL PLIST) (RETURN (REVERSE DONE))))
(SETQ PROP (SEEKPROP (CAR PLIST) (Q DEFACTION)))
(COND ((NULL PROP) (GO ELOOP)))
(SETQ DONE (CONS (CONS NAME (CAR PLIST)) DONE))
((PROPVAL PROP)
(LIST (Q DEFPROP) NAME (CADR PLIST) (CAR PLIST)))
ELOOP(SETQ PLIST (CDDR PLIST))
(GO LOOP)))
(DEFPROP COMPL
(LAMBDA (FILES)
(PROG (MSGCHAN)
(COND ((NOT (NULL LISTING))
(SETQ MSGCHAN (EVAL (MCONS (Q OUTPUT)
(GENSYM)
LISTING)))))
LOOP (COND ((NULL FILES) (OUTC MSGCHAN NIL)
(OUTC NIL T)
(RETURN NIL)))
(COND ((OR (EQ (CAR (LAST (EXPLODE (CAR FILES)))) *COLON)
(AND (NOT (ATOM (CAR FILES)))
(NOT (ATOM (CDAR FILES)))))
(SETQ INDEV (CAR FILES))
(GO ELOOP)))
(COMPFILE (LIST INDEV (CAR FILES))
(LIST OUTDEV
(CONS (COND ((ATOM (CAR FILES)) (CAR FILES))
(T (CAAR FILES)))
OUTEXT)))
ELOOP(SETQ FILES (CDR FILES))
(GO LOOP)))
FEXPR)
(DFUNC (COMPREADS) (READLOOP (FUNCTION ACTONEXPR)))
(DFUNC (CURFILE) (GETPROP (Q CURFILE) (Q NAME)))
(DFUNC (CURFUN) (GETPROP (Q CURFUN) (Q NAME)))
(DEFPROP DECLARE (LAMBDA (L) (MAPC (FUNCTION EVAL) L)) FEXPR)
(DFUNC (DEFEXPR DEF)
(PROG (FN EX)
(SETQ FN (CADR DEF))
(SETQ EX (CADDR DEF))
(COND ((OR (ATOM EX) (NOT (EQ (CAR EX) (Q LAMBDA))))
(FLUSHDEF DEF))
((AND (ATOM (CADR EX)) (NOT (NULL (CADR EX))))
(COND ((REMPROP FN (Q *UNDEF))
(PRINTMSG (CONS FN (Q (LSUBR USED AS SUBR))))))
(PUTPROP FN T (Q *LSUBR))
(COMPFUNC FN
(MCONS (Q LSUBR) (LIST (CADR EX)) (CDDR EX))
(Q LSUBR)))
(T (REMPROP FN (Q *UNDEF))
(PUTPROP FN T (Q *SUBR))
(COMPFUNC FN (CONS (Q SUBR) (CDR EX)) (Q SUBR))))
(TYPEFN FN)))
(DFUNC (DEFFEXPR DEF)
(PROG (FN EX)
(SETQ FN (CADR DEF))
(SETQ EX (CADDR DEF))
(COND ((REMPROP FN (Q *UNDEF))
(PRINTMSG (CONS FN (Q (FSUBR USED AS SUBR))))))
(PUTPROP FN T (Q *FSUBR))
(COMPFUNC FN (CONS (Q FSUBR) (CDR EX)) (Q FSUBR))
(TYPEFN FN)))
(DFUNC (DEFMACRO DEF)
(PROG NIL
(COND ((REMPROP (CADR DEF) (Q *UNDEF))
(PRINTMSG (CONS (CADR DEF) (Q (MACRO USED AS SUBR))))))
(PUTPROP (CADR DEF) (CADDR DEF) (Q MACRO))
(TYPEFN (CADR DEF))))
(DFUNC (DO*EXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *SUBR)))
(DFUNC (DO*FEXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *FSUBR)))
(DFUNC (DOACT XPR) ((GETPROP (CAR XPR) (Q COMPACTION)) XPR))
(DFUNC (DODE L)
(DEFEXPR (MAKDEF (CADR L) (CADDR L) (CADDDR L) (Q EXPR))))
(DFUNC (DODF L)
(DEFFEXPR (MAKDEF (CADR L) (CADDR L) (CADDDR L) (Q FEXPR))))
(DFUNC (DODM L)
(DEFMACRO (MAKDEF (CADR L) (CADDR L) (CADDDR L) (Q MACRO))))
(DFUNC (DOFILE DOREADS INFILE OUTFILE)
(PROG (LINCNT)
(SETQ LINCNT 0)
(EVAL (MCONS (Q INPUT) (Q INCHAN) INFILE))
(EVAL (MCONS (Q OUTPUT) (Q OUTCHAN) OUTFILE))
(INC (Q INCHAN) NIL)
(OUTC (Q OUTCHAN) NIL)
(DOREADS)
(OUTC NIL T)
(INC NIL T)))
(DFUNC (FLUSHEXPR EXPR)
(PROG2 (COND ((NOT (ATMARGIN)) (LINEF 2))) (PRINTEXPR EXPR)))
(DFUNC (FLUSHLAP ENTRY)
(PROG (NAME FLAG TYPE STAT)
(SETQ NAME (CADR ENTRY))
(SETQ FLAG (CADDR ENTRY))
(SETQ TYPE (ASSOC FLAG
(Q ((FSUBR *FSUBR) (LSUBR *LSUBR)
(SUBR *SUBR)))))
(COND ((NULL TYPE) (GO PRINT)))
(SETQ TYPE (CADR TYPE))
(COND ((AND (MEMQ TYPE (Q (*FSUBR *LSUBR)))
(GETPROP NAME (Q *UNDEF)))
(PRINTMSG (MCONS NAME FLAG (Q (USED AS SUBR))))))
(SETPROP NAME TYPE T)
(REMPROP NAME (Q *UNDEF))
(TYPEFN NAME)
PRINT(COND ((NOT (ATMARGIN)) (LINEF 2)))
(OUTPUTSTAT ENTRY)
LOOP (SETQ STAT (ERRSET (READ)))
(COND ((ATOM STAT) (USERERR READERR-FLUSHLAP)))
(OUTPUTSTAT (CAR STAT))
(COND ((NULL (CAR STAT)) (RETURN NIL)))
(GO LOOP)))
(DFUNC (MAKDEF NAME ARGS BODY TYPE)
(LIST (Q DEFPROP) NAME (LIST (Q LAMBDA) ARGS BODY) TYPE))
(DFUNC (MAPPUT EXP)
(PROG (IND ARGS)
(SETQ IND (CAR EXP))
(SETQ ARGS (CDR EXP))
LOOP (COND ((NULL ARGS) (RETURN EXP)))
(PUTPROP (CAR ARGS) T IND)
(SETQ ARGS (CDR ARGS))
(GO LOOP)))
(DFUNC (PRINTMSG MESSAGE)
(PROG (CHAN LINCNT)
(SETQ CHAN (OUTC MSGCHAN NIL))
(SETQ LINCNT 0)
(COND ((NOT (ATMARGIN)) (LINEF 2)))
(PRINL (CONS (Q *) MESSAGE))
(LINEF 1)
(OUTC CHAN NIL)))
(DFUNC (READLOOP ACTFUN)
(PROG (EXPR)
LOOP (SETQ EXPR (ERRSET (READ)))
(COND ((EQ EXPR (Q $EOF$)) (RETURN NIL)))
(ACTFUN (CAR EXPR))
(GO LOOP)))
(DEFPROP SPECIAL
(LAMBDA (X) (MAPCAR (FUNCTION MAKESPECIAL) X))
FEXPR)
(DFUNC (TELLTALE FILENAME STARTTIME)
(PROG (CHAN UNDS)
(SETQ CHAN (OUTC MSGCHAN NIL))
(CARRETN)
(LINEF 1)
(PRINL (LIST FILENAME (Q COMPILED)))
(PRINL (LIST CODESIZE (Q WORDS)))
(PRINL (LIST CONSTSIZE (Q CONSTANTS)))
(PRINL (LIST (ADD1 (QUOTIENT (DIFFERENCE (TIME) STARTTIME)
1750))
(Q SECONDS)))
(LINEF 2)
UNDF (COND ((NULL UNDFUNS) (GO UNDF1)))
(COND ((HASPROP (CAR UNDFUNS) (Q *UNDEF))
(SETQ UNDS (CONS (CAR UNDFUNS) UNDS))))
(SETQ UNDFUNS (CDR UNDFUNS))
(GO UNDF)
UNDF1(COND ((NULL UNDS) (GO GENF)))
(PRINL (Q (UNDEFINED FUNCTIONS)))
(LINEF 1)
(PRINL UNDS)
(LINEF 2)
GENF (COND ((NULL GENFUNS) (GO END)))
(PRINL (Q (GENERATED FUNCTIONS)))
(LINEF 1)
(PRINL GENFUNS)
(LINEF 2)
END (OUTC CHAN NIL)))
(DFUNC (TYPEFN MESSAGE)
(PROG (CHAN LINCNT)
(COND ((NULL SHOWNAMES) (RETURN NIL)))
(SETQ CHAN (OUTC MSGCHAN NIL))
(SETQ LINCNT 0)
(COND ((ATMARGIN) (LINEF 1)))
(PRINS MESSAGE)
(OUTC CHAN NIL)))
(DEFPROP UNSPECIAL
(LAMBDA (X) (MAPCAR (FUNCTION MAKEUNSPECIAL) X))
FEXPR)
(BEGINBLOCK INITIALIZATION)
(DFUNC (CINIT) (PROG2 (EXCISE) (INITFN (Q CSTART))))
(DFUNC (CSTART)
(PROG NIL
(INITFN NIL)
(COND ((NOT (NULL (ERRSET (INPUT SYS: (COMPLR . INI)) NIL)))
(SYSIN (COMPLR . INI))))
(COND ((NOT (NULL (ERRSET (INPUT DSK: (COMPLR . INI)) NIL)))
(SYSIN DSK: (COMPLR . INI))))
(LINEF 1)
(PRINL (Q (LISP COMPILER)))))
(ENDBLOCK INITIALIZATION)
(MAPDEF COMPEFFECT (COMPACTION DOACT) (MACRO ACTONMACRO))
(MAPDEF COMPACTION (DE DODE) (DECLARE EVAL) (DEFPROP COMPDEF)
(DF DODF) (DM DODM) (LAP FLUSHLAP) (SPECIAL EVAL)
(UNSPECIAL EVAL) (*SUBR MAPPUT) (*FSUBR MAPPUT)
(*LSUBR MAPPUT) (*EXPR MAPPUT) (*FEXPR MAPPUT))
(MAPDEF DEFACTION (EXPR DEFEXPR) (FEXPR DEFFEXPR) (MACRO DEFMACRO)
(SPECIAL EVAL) (DEFACTION EVAL) (*EXPR DO*EXPR)
(*FEXPR DO*FEXPR) (*SUBR EVAL) (*FSUBR EVAL)
(*LSUBR EVAL))
(SETQ LISTING NIL)
(SETQ OUTDEV (SETQ INDEV (QUOTE DSK:)))
(SETQ OUTEXT (QUOTE LAP))
(SETQ SHOWNAMES T)
(ENDBLOCK TOPLEVEL)
(BEGINBLOCK PASS1)
(DFUNC (DOP1 XPR) ((GETPROP (CAR XPR) (Q P1)) XPR))
(DFUNC (GENFUN EXPR)
(PROG (NAME ARGS CALL)
(COND ((ATOM EXPR) (RETURN EXPR)))
(COND ((NOT (EQ (CAR EXPR) (Q LAMBDA)))
(USERERR NOTLAMBDA-GENFUN)))
(SETQ ARGS (CADR EXPR))
(SETQ CALL (CADDR EXPR))
(COND ((AND (ATOM (CAR CALL)) (EQUAL ARGS (CDR CALL)))
(RETURN (CAR CALL))))
(SETQ NAME (MAKESYM (NEXTSYM (Q SUBFUN)) (CURFUN)))
(SETQ GENFUNS (CONS NAME GENFUNS))
(RETURN (COMPFUNC NAME (LIST (Q SUBR) ARGS CALL) (Q SUBR)))))
(DFUNC (MAPP1 ARGS) (MAPCAR (FUNCTION P1) ARGS))
(DFUNC (NEWNAME OLD)
(PROG (NEW)
(SETQ NEW (ASSOC OLD RENAMELIST))
(COND (NEW (RETURN (CDR NEW))))
(RETURN NIL)))
(DFUNC (P1 XPR)
(PROG (TEM)
(COND ((ATOM XPR) (GO ATOM)))
(COND ((ATOM (CAR XPR)) (GO ATOMC)))
(COND ((EQ (CAAR XPR) (Q LAMBDA)) (RETURN (P1LAM XPR))))
(COND ((EQ (CAAR XPR) (Q LABEL)) (RETURN (P1LABEL XPR))))
(RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))
ATOM (COND ((CONSTANTP XPR) (RETURN (LIST (Q QUOTE) XPR))))
(COND ((SETQ TEM (NEWNAME XPR)) (RETURN (P1 (CAR TEM)))))
(INCR P1CNT)
(COND ((SPECIALP XPR) (SETQ SPECVARS (ADDTOLIST XPR SPECVARS))
(RETURN XPR)))
(COND ((VARB XPR) (RETURN XPR)))
(PUTLOC XPR P1CNT)
(RETURN XPR)
ATOMC(COND ((CONSTANTP (CAR XPR)) (USERERR CONSTFUN-P1)))
(COND ((SETQ TEM (NEWNAME (CAR XPR)))
(RETURN (P1 (CONS (CAR TEM) (CDR XPR))))))
(COND ((SETQ TEM (GETGET (CAR XPR) (Q PASS1)))
(RETURN ((PROPVAL TEM) XPR))))
(COND ((OR (SPECIALP (CAR XPR)) (MEMBER (CAR XPR) ALLVARS))
(RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))))
(RETURN (P1ELSE XPR))))
(DFUNC (P1ANDOR XPR)
(PROG (TEM CT ARGS)
(SETQ TEM LOCVARS)
(SETQ CT P1CNT)
(SETQ ARGS (MAPP1 (CDR XPR)))
(INCR P1CNT)
(P1BUG CT P1CNT TEM)
(INCR P1CNT)
(RETURN (CONS (CAR XPR) ARGS))))
(DFUNC (P1BIND VARS)
(PROG (VAR NEWVARS)
(COND ((AND VARS (ATOM VARS)) (USERERR ATOMICVARLIST-P1BIND)))
LOOP (COND ((NULL VARS) (RETURN (REVERSE NEWVARS))))
(SETQ VAR (CAR VARS))
(COND ((NOT (VARIABLEP VAR)) (USERERR NOTVARIABLE-P1BIND)))
(COND ((MEMBER VAR NEWVARS) (USERWARN VAR REPEATED VARIABLE)))
(COND ((SPECIALP VAR) (SETQ SPECVARS (ADDTOLIST VAR SPECVARS))
(GO ELOOP))
((MEMBER VAR ALLVARS) (RENAME VAR (SETQ VAR (GENVAR)))))
(PUTLOC VAR 0)
ELOOP(SETQ ALLVARS (ADDTOLIST VAR ALLVARS))
(SETQ NEWVARS (CONS VAR NEWVARS))
(SETQ VARS (CDR VARS))
(GO LOOP)))
(DFUNC (P1BUG LOW HIGH PTR)
(PROG (X)
LOOP (COND ((NULL PTR) (RETURN NIL)))
(SETQ X (CAR PTR))
(COND ((GREATERP (CDR X) LOW) (RPLACD X HIGH)))
(SETQ PTR (CDR PTR))
(GO LOOP)))
(DFUNC (P1COND XPR)
(PROG (TEM CT PAIRS P1SCV)
(SETQ TEM LOCVARS)
(SETQ CT P1CNT)
(SETQ PAIRS (MAPCAR (FUNCTION MAPP1) (CDR XPR)))
(INCR P1CNT)
(P1BUG CT P1CNT TEM)
(INCR P1CNT)
(RETURN (MCONS (CAR XPR) P1SCV PAIRS))))
(DFUNC (P1CONS XPR)
(COND ((NOT (EQ (LENGTH (CDR XPR)) 2)) (USERERR ARGNO-P1CONS))
((NULL (CADDR XPR)) (LIST (Q NCONS) (P1 (CADR XPR))))
(T (LIST (Q CONS) (P1 (CADR XPR)) (P1 (CADDR XPR))))))
(DFUNC (P1ELSE XPR)
(PROG NIL
(SETQ UNDFUNS (CONS (CAR XPR) UNDFUNS))
(PUTPROP (CAR XPR) T (Q *UNDEF))
(RETURN (CONS (CAR XPR) (P1SUBRARGS (CDR XPR))))))
(DFUNC (P1ERRSET XPR)
(COND ((ATOM (CADR XPR)) XPR)
(T (MCONS (CAR XPR)
(LIST (GENFUN (LIST (Q LAMBDA) NIL (CADR XPR))))
(CDDR XPR)))))
(DFUNC (P1EVAL XPR)
(PROG (CDRXPR)
(SETQ CDRXPR (P1SUBRARGS (CDR XPR)))
(COND ((NOT (NULL (CDR CDRXPR)))
(RETURN (CONS (Q EVAL) CDRXPR))))
(RETURN (CONS (Q *EVAL) CDRXPR))))
(DFUNC (P1FUNCTION XPR)
(LIST (COND ((EQ (CAR XPR) (Q FUNCTION)) (Q QUOTE)) (T (CAR XPR)))
(GENFUN (CADR XPR))))
(DFUNC (P1GO XPR)
(PROG NIL
(COND ((NOT INPROG) (USERERR NOTINPROG-P1GO)))
(COND ((ATOM (CADR XPR)) (RETURN XPR)))
(RETURN (LIST (CAR XPR) (P1 (CADR XPR))))))
(DFUNC (P1LABEL XPR)
(PROG (FN)
(INITPROP (CADAR XPR) (Q FUNVAR) T)
(SETQ FN (P1 (LIST (Q FUNCTION) (CADDAR XPR))))
(DELETEPROP (CADAR XPR) (Q FUNVAR))
(RETURN (P1 (LIST (Q PROG)
(LIST (CADAR XPR))
(LIST (Q SETQ) (CADAR XPR) FN)
(LIST (Q RETURN)
(CONS (CADAR XPR) (CDR XPR))))))))
(DFUNC (P1LAM XPR)
(PROG (ARGS LAML BODY SAVERENAMELIST)
(SETQ SAVERENAMELIST RENAMELIST)
(SETQ ARGS (P1SUBRARGS (CDR XPR)))
(SETQ LAML (P1BIND (CADAR XPR)))
(SETQ BODY (P1 (CADDAR XPR)))
(INCR P1CNT)
(SETQ RENAMELIST SAVERENAMELIST)
(RETURN (CONS (LIST (Q LAMBDA) LAML BODY) ARGS))))
(DFUNC (P1PROG X)
(PROG (TAGLIST P1SCNT PR TEM P1LL INPROG SAVERENAMELIST)
(COND ((NULL (CDR X)) (USERERR PROGTOOSHORT-P1PROG)))
(SETQ INPROG T)
(SETQ X (CDR X))
(SETQ SAVERENAMELIST RENAMELIST)
(SETQ P1LL (P1BIND (CAR X)))
(SETQ TEM LOCVARS)
(SETQ P1SCNT (INCR P1CNT))
LOOP1(SETQ X (CDR X))
(COND ((NULL X) (GO END1)))
(INCR P1CNT)
(COND ((ATOM (CAR X))
(COND ((ASSOC (CAR X) TAGLIST)
(USERWARN (CAR X) MULTIPLY DEFINED TAG)))
(SETQ TAGLIST (CONS (CONS (CAR X) (GENTAG)) TAGLIST))
(SETQ PR (CONS (CAR X) PR)))
(T (SETQ PR (CONS (P1 (CAR X)) PR))))
(GO LOOP1)
END1 (INCR P1CNT)
(P1BUG P1SCNT P1CNT TEM)
(SETQ TEM (GETPROP (Q LOCVARS) (Q VALUE)))
LOOP (COND ((NULL (CDR TEM)) (GO END)))
(COND ((AND (MEMBER (CAADR TEM) P1LL) (ZEROP (CDADR TEM)))
(USERWARN (CAADR TEM) UNUSED PROG VARIABLE)
(SETQ SPECVARS (ADDTOLIST (CAADR TEM) SPECVARS))
(MAKESPECIAL (CAADR TEM))))
ELOOP(SETQ TEM (CDR TEM))
(GO LOOP)
END (INCR P1CNT)
(SETQ RENAMELIST SAVERENAMELIST)
(RETURN (MCONS (Q PROG) TAGLIST P1LL (REVERSE PR)))))
(DFUNC (P1RETURN XPR)
(COND ((NOT INPROG) (USERERR NOTINPROG-P1RETURN))
(T (LIST (Q RETURN)
(P1 (COND ((NULL (CDR XPR)) NIL) (T (CADR XPR))))))))
(DFUNC (P1SETQ XPR)
(PROG (VAR TEM VAL)
(COND ((NOT (VARIABLEP (CAR XPR)))
(USERERR NOTVARIABLE-P1SETQ)))
(SETQ VAR (COND ((SETQ TEM (NEWNAME (CADR XPR))) (CAR TEM))
(T (CADR XPR))))
(VARB VAR)
(SETQ P1SCV (CONS VAR P1SCV))
(SETQ VAL (P1 (CADDR XPR)))
(INCR P1CNT)
(INCR P1CNT)
(RETURN (LIST (Q SETQ) VAR VAL))))
(DFUNC (P1STORE XPR)
(PROG (ARG1 ARG2)
(SETQ ARG2 (P1 (CADDR XPR)))
(SETQ ARG1 (P1 (CADR XPR)))
(RETURN (LIST (CAR XPR) ARG1 ARG2))))
(DFUNC (P1SUBRARGS ARGS)
(COND ((GREATERP (LENGTH ARGS) NACS) (USERERR EXTRAARGS-P1SUBRARGS))
(T (MAPP1 ARGS))))
(DFUNC (PASS1 EXPR)
(PROG (ALLVARS LL RENAMELIST P1SCNT P1SCV INPROG FOUNDFREE LOCVS)
(SETQ INPROG NIL)
(SETQ P1CNT 1)
(SETQ LOCVARS (SETQ SPECVARS NIL))
(SETQ LL (P1BIND (CADR EXPR)))
(COND ((GREATERP (LENGTH LL) NACS) (USERERR EXTRAARGS-PASS1)))
(SETQ EXPR (LIST (CAR EXPR) LL (P1 (CADDR EXPR))))
(COND ((NOT (NULL FOUNDFREE)) (USERWARN (REVERSE FOUNDFREE)
UNDECLARED
FREE
VARIABLES)))
(SETQ LOCVS LOCVARS)
(SETQ LOCVARS NIL)
LOOP (COND ((NULL LOCVS) (RETURN EXPR)))
(COND ((NOT (SPECIALP (CAAR LOCVS)))
(SETQ LOCVARS (CONS (CAR LOCVS) LOCVARS))
(SETPROP (CAAR LOCVS) (Q LOCAL) T))
(T (SETQ SPECVARS (ADDTOLIST (CAAR LOCVS) SPECVARS))))
(SETQ LOCVS (CDR LOCVS))
(GO LOOP)))
(DFUNC (PASS1FSUBR XPR) XPR)
(DFUNC (PASS1FUNVAR XPR)
(CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))
(DFUNC (PASS1LSUBR XPR) (CONS (CAR XPR) (MAPP1 (CDR XPR))))
(DFUNC (PASS1MACRO XPR) (P1 ((GETPROP (CAR XPR) (Q MACRO)) XPR)))
(DFUNC (PASS1SUBR XPR) (CONS (CAR XPR) (P1SUBRARGS (CDR XPR))))
(DFUNC (PASS1UNDEF XPR)
(PROG2 (SETQ UNDFUNS (ADDTOLIST (CAR XPR) UNDFUNS))
(PASS1SUBR XPR)))
(DFUNC (PUTLOC IVAR NUMBER)
(PROG (TEM)
(SETQ TEM (ASSOC IVAR LOCVARS))
(COND (TEM (RETURN (RPLACD TEM NUMBER))))
(RETURN (SETQ LOCVARS (CONS (CONS IVAR NUMBER) LOCVARS)))))
(DFUNC (RENAME OLD NEW)
(SETQ RENAMELIST (CONS (LIST OLD NEW) RENAMELIST)))
(DFUNC (SPECIALP VAR) (HASPROP VAR (Q SPECIAL)))
(DFUNC (VARB X)
(PROG NIL
(COND ((MEMBER X ALLVARS) (RETURN NIL))
((SPECIALP X) (GO SPEC)))
(SETQ FOUNDFREE (CONS X FOUNDFREE))
(MAKESPECIAL X)
SPEC (SETQ SPECVARS (ADDTOLIST X SPECVARS))
(SETQ ALLVARS (ADDTOLIST X ALLVARS))
(RETURN T)))
(DFUNC (VARIABLEP EX) (AND (ATOM EX) (NOT (CONSTANTP EX))))
(MAPDEF PASS1 (EXPR PASS1SUBR) (*EXPR PASS1SUBR) (SUBR PASS1SUBR)
(*SUBR PASS1SUBR) (*UNDEF PASS1UNDEF)
(LSUBR PASS1LSUBR) (*LSUBR PASS1LSUBR)
(FEXPR PASS1FSUBR) (*FEXPR PASS1FSUBR)
(FSUBR PASS1FSUBR) (*FSUBR PASS1FSUBR) (P1 DOP1)
(FUNVAR PASS1FUNVAR) (MACRO PASS1MACRO))
(MAPDEF P1 (COND P1COND) (GO P1GO) (PROG P1PROG) (EVAL P1EVAL)
(ERRSET P1ERRSET) (SETQ P1SETQ) (STORE P1STORE)
(AND P1ANDOR) (CONS P1CONS) (OR P1ANDOR)
(*FUNCTION P1FUNCTION) (FUNCTION P1FUNCTION)
(RETURN P1RETURN))
(BEGINBLOCK INTERNALMACROS)
(DEFPROP INMACRO PASS1INMACRO PASS1)
(DFUNC (PASS1INMACRO XPR) (P1 ((GETPROP (CAR XPR) (Q INMACRO)) XPR)))
(DEFPROP INMACRO
(LAMBDA (DF)
(COMPFUNC (CADR DF) (CONS (Q SUBR) (CDADDR DF)) (Q INMACRO)))
DEFACTION)
(DEFPROP APPEND
(LAMBDA (L)
(COND ((NULL (CDR L)) NIL)
((NULL (CDDR L)) (CADR L))
(T (LIST (Q *APPEND) (CADR L) (CONS (CAR L) (CDDR L))))))
INMACRO)
(DEFPROP LIST
(LAMBDA (L)
(COND ((NULL (CDR L)) NIL)
((NULL (CDDR L)) (CONS (Q NCONS) (CDR L)))
(T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
INMACRO)
(DEFPROP NOT (LAMBDA (L) (CONS (Q NULL) (CDR L))) INMACRO)
(DEFPROP ZEROP (LAMBDA (L) (LIST (Q EQ) (CADR L) (Q 0))) INMACRO)
(ENDBLOCK INTERNALMACROS)
(ENDBLOCK PASS1)
(BEGINBLOCK PASS2)
(DFUNC (ACEFFECTS FN)
(COND ((SETQ FN (SEEKPROP FN (Q ACS))) (PROPVAL FN)) (T ALLACS)))
(DFUNC (ACNUMP X)
(AND (NUMBERP X) (GREATERP X 0) (LESSP X (ADD1 NACS))))
(DFUNC (BINDVARS VARS LAMBDAP)
(PROG (VAR ACNUM SPFLG)
(SETQ ACNUM 1)
A (COND ((NULL VARS) (RETURN SPFLG)))
(SETQ VAR (CAR VARS))
(COND ((SPECVARP VAR) (GO SP1))
((ASSOC VAR LOCVARS) (GO LV1))
(T (COMPERR FUNNYVAR-BINDVARS) (GO SP2)))
LV1 (COND (LAMBDAP (SETSLOT ACNUM (LIST VAR))))
SP2 (SETQ ACNUM (ADD1 ACNUM))
(SETQ VARS (CDR VARS))
(GO A)
SP1 (COND ((NOT PRGSPFLG) (GO B)))
SP3 (OUTINST (LIST 0
(COND (LAMBDAP ACNUM) (T 0))
(LIST (Q SPECIAL) VAR)))
(GO LV1)
B (SETQ PRGSPFLG (SETQ SPFLG T))
(OUTINST (Q (JSP 6 SPECBIND)))
(GO SP3)))
(DFUNC (BOOLAND EXP VALAC TAG FLAG)
(PROG NIL
(BOOL2 (CDR EXP) VALAC TAG T FLAG)
(INCR P2CNT)
(INCR P2CNT)))
(DFUNC (BOOLEQ EXP VALAC TAG FLAG)
(PROG NIL
(BOOLEQ1 (CDR EXP) VALAC TAG FLAG)
(OUTJRST TAG)
(RSLSET TAG)
(RETURN NIL)))
(DFUNC (BOOLEQ1 EXP VALAC TAG F)
(PROG (ARG1 ARG2 LOC1 LOC2 AC MEM)
(COND ((NOT (EQ (LENGTH EXP) 2)) (USERERR ARGNOERR-BOOLEQ1)))
(SETQ ARG1 (COMP (CAR EXP) (FREEAC)))
(SETQ ARG2 (COMP (CADR EXP) (FREEAC)))
(SETQ LOC2 (LOC ARG2))
(SETQ LOC1 (LOC ARG1))
(RST TAG)
(COND ((ACNUMP LOC1) (SETQ AC LOC1) (SETQ MEM (LOC ARG2)))
((ACNUMP LOC2) (SETQ AC LOC2) (SETQ MEM (LOC ARG1)))
(T (LOADARG (SETQ AC (FREEAC)) ARG1)
(SETQ MEM (LOC ARG2))))
(REMOVE ARG1)
(REMOVE ARG2)
(SAVEACS)
(OUT1 (COND (F (Q CAMN)) (T (Q CAME))) AC MEM)))
(DFUNC (BOOLEXPR EXP VALAC TAG FLAG MINDEPTH)
(PROG (TEM)
(COND ((ATOM EXP) (GO ELSE)))
(COND ((SETQ TEM (SEEKPROP (CAR EXP) (Q BOOL)))
(RETURN ((PROPVAL TEM) EXP VALAC TAG FLAG))))
ELSE (SETQ EXP (PUTINAC (COMP EXP VALAC)
(COND (VALAC) ((FREEAC)))))
(OUTCJMP FLAG EXP TAG)
(COND (FLAG (RSLSET TAG) (SETSLOT EXP (Q (QUOTE NIL))))
(T (SETQ FLAG (SLOTCONT EXP))
(SETSLOT EXP (Q (QUOTE NIL)))
(RSLSET TAG)
(SETSLOT EXP FLAG)))))
(DFUNC (BOOL2 EXP VALAC TAG F1 F2)
(PROG (G)
(CLEAR1)
(RST TAG)
(PUTPROP (SETQ G (GENTAG)) (TOPCOPY PDL) (Q LEVEL))
A (COND ((NULL EXP) (COND (F2 (OUTJRST TAG))) (GO C)))
(COND ((AND F2 (NULL (CDR EXP))) (GO B)))
(BOOLEXPR (CAR EXP)
VALAC
(COND (F2 G) (T TAG))
(NOT F1)
MINDEPTH)
(SETQ EXP (CDR EXP))
(GO A)
B (BOOLEXPR (CAR EXP) VALAC TAG F1 MINDEPTH)
(OUTENDTAG G)
C (CLEAR2BOTH)
(CLEARACS)))
(DFUNC (BOOLNULL EXP VALAC TAG FLAG)
(BOOLEXPR (CADR EXP) VALAC TAG (NOT FLAG) MINDEPTH))
(DFUNC (BOOLOR EXP VALAC TAG FLAG)
(PROG NIL
(BOOL2 (CDR EXP) VALAC TAG NIL (NOT FLAG))
(INCR P2CNT)
(INCR P2CNT)))
(DFUNC (BOOLQUOTE EXP VALAC TAG FLAG)
(BOOL2 NIL VALAC TAG NIL (IFIF FLAG (CADR EXP))))
(DFUNC (BOOLVALUE VALAC EFFECTS TAG)
(PROG NIL
(COND ((NOT EFFECTS) (OUT1 (Q TDZA) VALAC VALAC)))
(OUTENDTAG TAG)
(COND ((NOT EFFECTS) (OUT1 (Q MOVEI) VALAC (Q (QUOTE T)))))
(RETURN (COND (EFFECTS NIL) (T (MARKVAL VALAC))))))
(DFUNC (CALLFSUBR XPR VALAC EFFECTS)
(PROG (FUN ARGS VAL)
(SETQ FUN (CAR XPR))
(SETQ ARGS (CDR XPR))
(CLEAR2BOTH)
(LOADARG FARGAC (LIST (Q QUOTE) ARGS))
(PROTECTACS FUN)
(COND ((NOT (NULL VALAC)) (SETQ VAL (MARKVAL VALUEAC))))
(OUTCALL 17 FUN)
(RETURN VAL)))
(DFUNC (CALLFUNARGS XPR VALAC EFFECTS)
(PROG (FUN ARGS FUNARGS LOCS VAL)
(SETQ FUN (CAR XPR))
(SETQ ARGS (CDR XPR))
(SETQ FUNARGS (COMP FUN VALAC))
(SETQ LOCS (COMPARGS ARGS))
(CLRCCLST LOCS)
(LOADSUBRARGS LOCS)
(CLEAR2BOTH)
(CLEARACS)
(COND ((NOT (NULL VALAC)) (SETQ VAL (MARKVAL VALUEAC))))
(OUTCALLF (LENGTH LOCS) (LOC FUNARGS))
(REMOVE FUNARGS)
(RETURN VAL)))
(DFUNC (CALLLSUBR XPR VALAC EFFECTS)
(PROG (FUN ARGS NARGS HOME INST RETTAG TEM VAL)
(SETQ FUN (CAR XPR))
(SETQ ARGS (CDR XPR))
(CLEAR1)
(SETQ NARGS (LENGTH ARGS))
(SLOTPUSH (Q (NIL . TAKEN)))
(OUTPUSH (GENCONST 0 0 (SETQ RETTAG (GENTAG)) 0 0))
LOOP (COND ((NULL ARGS) (GO CALL)))
(SETQ HOME (TOPCOPY PDL))
(SETQ INST (COMP (CAR ARGS) VALAC))
(RESTORE HOME)
(SETQ TEM (LOC INST))
(SLOTPUSH (Q (NIL . TAKEN)))
(OUTPUSH TEM)
(REMOVE INST)
(SETQ ARGS (CDR ARGS))
(GO LOOP)
CALL (SETQ TEM (PDLDEPTH))
(SAVEACS)
(COND ((NOT (EQ (PDLDEPTH) TEM))
(COMPERR PDLTOOLONG-LSUBRCALL)))
(OUTINST (LIST (Q MOVNI) 6 NARGS))
LLOOP(SLOTPOP)
(COND ((ZEROP NARGS) (GO CALL1)))
(SETQ NARGS (SUB1 NARGS))
(GO LLOOP)
CALL1(CLEAR2BOTH)
(CLEARACS)
(COND ((NOT (NULL VALAC)) (SETQ VAL (MARKVAL VALUEAC))))
(OUTJCALL 16 FUN)
(OUTTAG RETTAG)
(RETURN VAL)))
(DFUNC (CALLSUBR XPR VALAC EFFECTS)
(PROG (FUN ARGS NARGS LOCS TEM VAL)
(SETQ FUN (CAR XPR))
(SETQ ARGS (CDR XPR))
(SETQ LOCS (COMPARGS ARGS))
(SETQ NARGS (LENGTH LOCS))
(COND ((AND (SETQ TEM (SEEKPROP FUN (Q COMMU)))
(EQ NARGS 2)
(EQ (ILOC (CAR LOCS) VALUEAC) VALUEAC))
(SETQ LOCS (REVERSE LOCS))
(SETQ FUN (PROPVAL TEM))))
(SETQ TEM (SIDEEFFECTS FUN))
(COND (TEM (CLRCCLST LOCS)))
(LOADSUBRARGS LOCS)
(COND (TEM (CLEAR2BOTH)))
(PROTECTACS FUN)
(COND ((NOT (NULL VALAC)) (SETQ VAL (MARKVAL VALUEAC))))
(OUTCALL NARGS FUN)
(RETURN VAL)))
(DFUNC (CLEAR1)
(PROG NIL (CLEAR1BOTH) (SAVEACS) (RETURN (CLRPVARS))))
(DFUNC (CLEAR1BOTH) (PROG NIL (CLRCCLST1 VALUEAC) (CLRSPLD)))
(DFUNC (CLEAR2BOTH) (PROG NIL (CLRCCLST2 VALUEAC) (CLRSPLD)))
(DFUNC (CLEARAC ACNO) (PROG NIL (CPUSH ACNO) (SETSLOT ACNO NIL)))
(DFUNC (CLEARITALL) (PROG NIL (CLEAR2BOTH) (CLEARACS)))
(DFUNC (CLEARACS)
(PROG (ACNO)
(SETQ ACNO NACS)
LOOP (COND ((ZEROP ACNO) (RETURN NIL)))
(CLEARAC ACNO)
(SETQ ACNO (SUB1 ACNO))
(GO LOOP)))
(DFUNC (CLRCCLST DATA)
(PROG (CCL)
(SETQ CCL CCLST)
LOOP (COND ((NULL CCL) (RETURN NIL)))
(COND ((ASSOC (CAAR CCL) DATA) (GO ELOOP)))
(CSFUN (CAR CCL) VALUEAC)
ELOOP(SETQ CCL (CDR CCL))
(GO LOOP)))
(DFUNC (CLRCCLST1 AC)
(PROG (CCL)
(SETQ CCL CCLST)
LOOP (COND ((NULL CCL) (RETURN NIL)))
(CSFUN (CAR CCL) AC)
(SETQ CCL (CDR CCL))
(GO LOOP)))
(DFUNC (CLRCCLST2 AC)
(PROG NIL
LOOP (COND ((NULL CCLST) (RETURN NIL)))
(CSFUN (CAR CCLST) AC)
(SETQ CCLST (CDR CCLST))
(GO LOOP)))
(DFUNC (CLRPVARS)
(PROG NIL
(COND ((NOT PROGSW) (RETURN NIL)))
(SETQ PROGSW NIL)
LOOP (COND ((NULL PROGVARS) (SETQ PRSSL (TOPCOPY PDL))
(SETQ MINDEPTH (PDLDEPTH))
(RETURN NIL))
((NOT (ILOC (CONS (CAR PROGVARS) P2CNT) VALUEAC))
(INITZ (CAR PROGVARS))))
(SETQ PROGVARS (CDR PROGVARS))
(GO LOOP)))
(DFUNC (CLRSPLD)
(PROG NIL
LOOP (COND ((NULL SPLDLST) (RETURN NIL)))
(CLRSPVAR (CAR SPLDLST))
(SETQ SPLDLST (CDR SPLDLST))
(GO LOOP)))
(DFUNC (CLRSPVAR L)
(PROG (LOC)
(SETQ LOC (ILOC (CONS (CAR L) P2CNT) VALUEAC))
(COND ((NOT (NUMBERP LOC)) (OUTSPECPUSH (CAR L)))
((ACNUMP LOC) (SLOTPUSH (SLOTCONT LOC)) (OUTPUSH LOC)))
(RETURN NIL)))
(DFUNC (COMP XPR VALAC) (COMPEXPR XPR VALAC NIL))
(DFUNC (COMPARGS ARGS)
(PROG (ARGNO RESULT)
(SETQ ARGNO 0)
LOOP (COND ((NULL ARGS) (RETURN RESULT)))
(SETQ ARGNO (ADD1 ARGNO))
(SETQ RESULT (CONS (COMP (CAR ARGS) ARGNO) RESULT))
(SETQ ARGS (CDR ARGS))
(GO LOOP)))
(DFUNC (COMPE XPR VALAC) (REMOVE (COMPEXPR XPR VALAC T)))
(DFUNC (COMPEXPR XPR VALAC EFFECTS)
(PROG (TEM)
(COND ((ATOM XPR) (GO ATOM)))
(COND ((ATOM (CAR XPR)) (GO ATOMC)))
(COND ((EQ (CAAR XPR) (Q LAMBDA))
(RETURN (INTERNALLAMBDA XPR VALAC EFFECTS))))
(RETURN (CALLFUNARGS XPR VALAC EFFECTS))
ATOM (SETQ TEM (CONS XPR (INCR P2CNT)))
(COND ((SPECVARP XPR) (SETQ SPLDLST (CONS TEM SPLDLST))))
(SETQ LDLST (CONS TEM LDLST))
(RETURN TEM)
ATOMC(COND ((SETQ TEM (GETGET (CAR XPR) (Q PASS2)))
(RETURN ((PROPVAL TEM) XPR VALAC EFFECTS))))
(COND ((OR (SPECVARP (CAR XPR)) (ASSOC (CAR XPR) LOCVARS))
(RETURN (CALLFUNARGS XPR VALAC EFFECTS))))
(RETURN (P2ELSE XPR VALAC EFFECTS))))
(DFUNC (COPT FUN AC ARGLOC)
(PROG (CCL TEM YLOC)
(SETQ YLOC (ILOC ARGLOC AC))
(SETQ CCL CCLST)
LOOP (COND ((NULL CCL) (RETURN NIL))
((AND (EQ FUN (CADAR CCL))
(EQUAL (ILOC (CDDAR CCL) AC) YLOC)
(ILOC (SETQ TEM (LIST (CAAR CCL))) AC))
(RETURN TEM)))
(SETQ CCL (CDR CCL))
(GO LOOP)))
(DFUNC (CPUSH ACNO)
(PROG (TEMPDL SLOTNO SLOTCON HOLDSLOT)
(COND ((NOT (DVP (SETQ SLOTCON (SLOTCONT ACNO))))
(RETURN NIL)))
(COND ((LESSP ACNO 1) (GO MAKE)))
START(SETQ SLOTNO 0)
(SETQ TEMPDL PDL)
LOOP (COND ((NULL TEMPDL) (GO NONE)))
(COND ((DVP (CAR TEMPDL)) (GO ELOOP)))
(COND ((OR (NOT (NUMBERP (CDAR TEMPDL)))
(SPECVARP (CAAR TEMPDL)))
(SETQ HOLDSLOT SLOTNO)))
(COND ((EQ (CAR SLOTCON) (CAAR TEMPDL)) (GO FOUND)))
ELOOP(SETQ TEMPDL (CDR TEMPDL))
(SETQ SLOTNO (SUB1 SLOTNO))
(GO LOOP)
FOUND(SETSLOT SLOTNO SLOTCON)
(COND ((NULL (CDR SLOTCON))
(SETSLOT ACNO (CONS (CAR SLOTCON) (Q DUP)))))
(OUTMOVEM ACNO SLOTNO)
(RETURN NIL)
NONE (COND (HOLDSLOT (SETQ SLOTNO HOLDSLOT) (GO FOUND)))
MAKE (COND ((AND PROGSW (NOT (ASSOC (CAR SLOTCON) LOCVARS)))
(SETQ TEMPDL (PDLDEPTH))
(CLRPVARS)
(COND ((LESSP ACNO 1)
(SETQ ACNO (PLUS ACNO
(DIFFERENCE TEMPDL
(PDLDEPTH))))))))
(SLOTPUSH SLOTCON)
(COND ((NULL (CDR SLOTCON))
(SETSLOT ACNO (CONS (CAR SLOTCON) (Q DUP)))))
(OUTPUSH ACNO)
(RETURN NIL)))
(DFUNC (CSFUN L AC)
(PROG (Y)
(COND ((AND (SETQ Y (ASSOC (CAR L) LDLST)) (NOT (ILOC Y AC)))
(LOADCARCDR L AC)))))
(DFUNC (CSTEP FUN AC ARGLOC)
(PROG (TEM)
(COND ((NULL FUN) (RETURN (LIST ARGLOC))))
(RETURN (CONS (CAR (SETQ TEM (GETPROP FUN (Q CARCDR))))
(CSTEP (CDR TEM) AC ARGLOC)))))
(DFUNC (DOP2 XPR VALAC EFFECTS)
((GETPROP (CAR XPR) (Q P2)) XPR VALAC EFFECTS))
(DFUNC (DVP X)
(PROG (Y Z)
(COND ((NULL X) (RETURN NIL)))
(COND ((EQ (CAR X) (Q QUOTE)) (RETURN NIL)))
(COND ((EQ (CDR X) (Q DUP)) (RETURN NIL)))
(COND ((EQ (CDR X) (Q TAKEN)) (RETURN T)))
(COND ((AND (SPECVARP (CAR X)) (NULL (CDR X))) (RETURN NIL)))
(COND ((AND (SETQ Y (ASSOC (CAR X) LOCVARS))
(NULL (CDR X))
(LESSP P2CNT (CDR Y)))
(RETURN T)))
(SETQ Z LDLST)
LOOP (COND ((NULL Z)
(RETURN (COND ((SETQ Z (ASSOC (CAR X) VARLIST))
(DVP (CONS (CDR Z) (CDR X))))
(T NIL)))))
(COND ((AND (EQ (CAAR Z) (CAR X))
(EQUAL (LOC (COND ((NUMBERP (CDR X)) X)
(T (CONS (CAR X) P2CNT))))
(LOC (CAR Z))))
(RETURN T)))
(SETQ Z (CDR Z))
(GO LOOP)))
(DFUNC (EQUIVTAG PTAG)
(PROG (LTAG)
(COND ((SETQ LTAG (ASSOC PTAG GOLIST)) (RETURN (CDR LTAG))))
(USERWARN PTAG UNDEFINED TAG)
(RETURN EXIT)))
(DFUNC (EXITBUM SPECFLAG)
(PROG (TEM1 TEM2)
(COND ((SETQ TEM1 (ASSOC (CAAR LASTOUT)
(Q ((CALL JCALL) (PUSHJ JRST)))))
(SETQ TEM2 (CAR LASTOUT))
(SETQ LASTOUT NIL)
(KILLPDL)
(OUTINST TEM2)
(COND ((NOT SPECFLAG)
(SETQ TEM2 (CAR LASTOUT))
(SETQ LASTOUT NIL)
(OUTINST (MCONS (CADR TEM1)
(SUBST 0 (Q P) (CADR TEM2))
(CDDR TEM2)))
(RETURN NIL)))))
(KILLPDL)
(COND (SPECFLAG (OUTINST (Q (JRST 0 SPECSTR))))
(T (OUTINST (Q (POPJ P)))))))
(DFUNC (FREEAC) (FREEAC1 VALUEAC))
(DFUNC (FREEAC1 BEST)
(PROG (ACNO ACCS)
(COND ((AND (NOT (NULL BEST)) (NOT (DVP (SLOTCONT BEST))))
(RETURN BEST)))
(SETQ ACCS ACS)
(SETQ ACNO 1)
LOOP (COND ((NULL ACCS) (COND ((NULL BEST) (RETURN NIL))
(T (CPUSH BEST) (RETURN BEST)))))
(COND ((NOT (DVP (CAR ACCS))) (RETURN ACNO)))
(SETQ ACCS (CDR ACCS))
(SETQ ACNO (ADD1 ACNO))
(GO LOOP)))
(DFUNC (FINDFREEAC) (FREEAC1 NIL))
(DFUNC (FREEZE VAR) (PROG NIL (FREEZE1 VAR ACS) (FREEZE1 VAR PDL)))
(DFUNC (FREEZE1 X Z)
(PROG NIL
LP (COND ((NULL Z) (RETURN NIL))
((EQ X (CAAR Z))
(COND ((OR (NULL (CDAR Z)) (EQ (CDAR Z) (Q DUP)))
(RPLACA Z (CONS X P2CNT))))))
(SETQ Z (CDR Z))
(GO LP)))
(DFUNC (GENCONST OP AC AD IN IB)
(PROG (ANS)
(COND ((NOT (ZEROP IB)) (SETQ ANS (LIST *AT))))
(SETQ ANS (APPEND ANS (LIST AC AD IN)))
(SETQ ANS (CONS OP ANS))
(RETURN (CONS (Q C) ANS))))
(DFUNC (GETSLOT NO)
(COND ((NOT (NUMBERP NO)) (COMPERR NOTSLOT-GETSLOT))
((GREATERP NO NACS) (PRINTMSG NO) (COMPERR NOTAC-GETSLOT))
((GREATERP NO 0) (NTHCDR (SUB1 NO) ACS))
((GREATERP (ABS NO) (PDLDEPTH)) (PRINTMSG NO)
(COMPERR NOTONPDL-GETSLOT))
((NTHCDR (MINUS NO) PDL))))
(DFUNC (ILOC X AC)
(PROG (CNTR BEST BESTNO SL SLOT CNT XCNT)
(COND ((NULL AC) (GO LOOK)))
(COND ((EQUAL X (SLOTCONT AC)) (RETURN AC)))
LOOK (COND ((EQ (CAR X) (Q QUOTE)) (RETURN (LIST X))))
(SETQ SL (SLOTLIST))
(SETQ CNTR 1)
(SETQ BESTNO (ADD1 P2CNT))
(SETQ XCNT (COND ((NUMBERP (CDR X)) (CDR X)) (T P2CNT)))
LOOP (COND ((NULL SL) (GO EXIT)))
(SETQ SLOT (CAR SL))
(COND ((AND SLOT (EQ (CAR SLOT) (CAR X))) (GO ISONE)))
ELOOP(SETQ SL (CDR SL))
(SETQ CNTR (ADD1 CNTR))
(GO LOOP)
EXIT (COND ((NOT (GREATERP BESTNO P2CNT)) (GO RETN)))
(COND ((SPECIALP (CAR X))
(RETURN (LIST (QUOTE SPECIAL) (CAR X)))))
(RETURN NIL)
ISONE(COND ((EQ (CDR SLOT) (Q TAKEN)) (GO ELOOP)))
(SETQ CNT (COND ((NUMBERP (CDR SLOT)) (CDR SLOT)) (T P2CNT)))
(COND ((AND (NOT (LESSP CNT XCNT)) (LESSP CNT BESTNO))
(SETQ BESTNO CNT)
(SETQ BEST CNTR)))
(GO ELOOP)
RETN (RETURN (COND ((NOT (GREATERP BEST NACS)) BEST)
(T (PLUS (MINUS BEST) NACS 1))))))
(DFUNC (ILOC1 X AC)
(PROG (Z)
(COND ((SETQ Z (ILOC X AC)) (RETURN Z)))
(COND ((MEMBER (CAR X) PROGVARS) (RETURN (Q ((QUOTE NIL))))))
(COND ((SETQ Z (ASSOCR (CAR X) VARLIST))
(RETURN (ILOC1 (CONS (CAR Z) (CDR X)) AC))))
(COND ((SETQ Z (ASSOC (CAR X) CCLST))
(RETURN (LOADCARCDR Z
(COND ((NULL AC) (FREEAC))
(T AC))))))
(PRINTMSG (LIST X))
(COMPERR LOSTVAR-ILOC1)))
(DFUNC (INITZ X)
(PROG NIL (SLOTPUSH (LIST X)) (OUTPUSH (Q ((QUOTE NIL))))))
(DFUNC (INTERNALLAMBDA XPR VALAC EFFECTS)
(PROG (LAMXPR LAMARGS SF LAMVARS TL ACL TEM)
(SETQ LAMXPR (CAR XPR))
(SETQ LAMVARS (CADR LAMXPR))
(SETQ LAMARGS (REVERSE (COMPARGS (CDR XPR))))
(COND ((NOT (EQUAL (LENGTH LAMVARS) (LENGTH LAMARGS)))
(USERERR ARGNOERR-INTERNALLAMBDA)))
A (COND ((NULL LAMVARS) (GO B)))
(SETQ TL (ILOC1 (CAR LAMARGS) (FREEAC)))
(REMOVE (CAR LAMARGS))
(COND ((SPECVARP (CAR LAMVARS))
(SETQ SF T)
(COND ((OR (NOT (NUMBERP TL)) (LESSP TL 1))
(LOADARG (SETQ TL (FREEAC)) (CAR LAMARGS)))))
((OR (NOT (NUMBERP TL)) (DVP (SETQ TEM (SLOTCONT TL))))
(SLOTPUSH TEM)
(COND ((NULL (CDR TEM))
(SETSLOT TL (CONS (CAR TEM) (Q DUP)))))
(OUTPUSH TL)
(SETQ TL 0)))
(SETSLOT TL (CONS (CAR LAMVARS) (Q TAKEN)))
(SETQ ACL (CONS TL ACL))
(SETQ LAMARGS (CDR LAMARGS))
(SETQ LAMVARS (CDR LAMVARS))
(GO A)
B (COND (SF (OUTINST (Q (JSP 6 SPECBIND)))))
(SETQ LAMVARS (CADR LAMXPR))
(SETQ ACL (REVERSE ACL))
C (COND ((NULL LAMVARS) (GO D))
((SPECVARP (CAR LAMVARS))
(INTLAM1 (CAR LAMVARS) ACS)
(INTLAM1 (CAR LAMVARS) PDL)
(OUTINST (LIST 0
(CAR ACL)
(LIST (Q SPECIAL) (CAR LAMVARS))))))
(RPLACD (SLOTCONT (CAR ACL)) NIL)
(SETQ LAMVARS (CDR LAMVARS))
(SETQ ACL (CDR ACL))
(GO C)
D (SETQ TEM (COMP (CADDR LAMXPR) VALAC))
(COND (SF (OUTINST (Q (PUSHJ P SPECSTR)))))
(INCR P2CNT)
E (COND ((NULL LAMVARS) (RETURN TEM))
((SPECVARP (CAR LAMVARS)) (INTLAM1 (CAR LAMVARS) ACS)
(INTLAM1 (CAR LAMVARS) PDL)))
(SETQ LAMVARS (CDR LAMVARS))
(GO E)))
(DFUNC (INTLAM1 SPECVAR STORE)
(PROG NIL
A (COND ((NULL STORE) (RETURN NIL))
((AND (NOT (NULL (CAR STORE)))
(EQ (CAAR STORE) SPECVAR)
(NULL (CDAR STORE)))
(RPLACA STORE NIL)))
(SETQ STORE (CDR STORE))
(GO A)))
(DFUNC (KILLPDL) (RESTORE NIL))
(DFUNC (LAMBDABIND VARS) (BINDVARS VARS T))
(DFUNC (LISTNILS NUMBER)
(PROG (LIST)
LOOP (COND ((ZEROP NUMBER) (RETURN LIST)))
(SETQ LIST (CONS NIL LIST))
(SETQ NUMBER (SUB1 NUMBER))
(GO LOOP)))
(DFUNC (LOADARG ACNO VAR)
(PROG (DATAORG OLDACC DATACONT DAC DOD)
(REMOVE VAR)
(SETQ DATAORG (ILOC1 VAR ACNO))
(SETQ OLDACC (SLOTCONT ACNO))
(SETQ DATACONT (COND ((NUMBERP DATAORG) (SLOTCONT DATAORG))))
(SETQ DAC (DVP OLDACC))
(SETQ DOD (DVP DATACONT))
(COND ((EQ ACNO DATAORG) (COND (DAC (CPUSH ACNO)))
(RETURN NIL)))
(COND ((AND (EQ DATAORG 0)
(NOT DOD)
(NOT DAC)
(GREATERP (PDLDEPTH) MINDEPTH))
(GO POP)))
(COND ((AND (NOT DOD)
(NOT (NULL OLDACC))
(NUMBERP DATAORG)
~ (GREATERP DATAORG
~ (DIFFERENCE MINDEPTH (PDLDEPTH)))
(LESSP DATAORG ACNO))
(GO EXCH)))
(COND ((NOT DAC) (GO FREE)))
(GO PUSH)
EXCH (SETSLOT DATAORG OLDACC)
(SETSLOT ACNO DATACONT)
(OUT1 (Q EXCH) ACNO DATAORG)
(RETURN NIL)
PUSH (CPUSH ACNO)
(SETQ DATAORG (LOC VAR))
FREE (COND ((NOT (NUMBERP DATAORG)) (GO MOVE)))
(SETSLOT ACNO
(COND ((NULL (CDR DATACONT))
(CONS (CAR DATACONT) (Q DUP)))
(T DATACONT)))
(OUTMOVE ACNO DATAORG)
(RETURN NIL)
POP (SETSLOT ACNO DATACONT)
(OUTPOP ACNO)
(RETURN NIL)
MOVE (SETSLOT ACNO
(COND ((EQ (CAAR DATAORG) (Q QUOTE)) (CAR DATAORG))
(T (LIST (CAR VAR)))))
(OUTMOVE ACNO DATAORG)
(RETURN NIL)))
(DFUNC (LOADCARCDR ITEM AC)
(PROG (ARG PATH ORIG)
(COND ((EQ (ILOC1 (SETQ ARG (CDDR ITEM)) AC) AC)
(REMOVE ARG)))
(SETQ PATH (CSTEP (CADR ITEM) AC ARG))
(COND ((NULL (CDR PATH))
(SETQ VARLIST (CONS (CONS (CAR (CAR PATH)) (CAR ITEM))
VARLIST))
(REMOVE ARG)
(RETURN (LOC (CAR PATH)))))
(SETQ PATH (REVERSE PATH))
(CPUSH AC)
(SETQ ORIG (LOC (CAR PATH)))
(SETQ PATH (CDR PATH))
(REMOVE ARG)
L1 (COND ((NULL PATH) (GO RET)))
(COND ((NULL (CDR PATH)) (GO L2)))
(COND ((AND (EQ AC VALUEAC) (EQ ORIG VALUEAC))
(OUTCALL 1
(READLIST (CONS (Q C)
(REVERSE (CONS (Q R) PATH)))))
(GO RET)))
L2 (OUT1 (CADR (ASSOC (CAR PATH) (Q ((A HLRZ@) (D HRRZ@)))))
AC
ORIG)
(SETQ PATH (CDR PATH))
(SETQ ORIG AC)
(GO L1)
RET (SETSLOT AC (LIST (CAR ITEM)))
(RETURN AC)))
(DFUNC (LOADCOMP XPR AC) (LOADARG AC (COMP XPR AC)))
(DFUNC (LOADSUBRARGS ARGS)
(PROG (ARGNO)
(SETQ ARGNO (LENGTH ARGS))
LOOP (COND ((NULL ARGS) (RETURN NIL)))
(LOADARG ARGNO (CAR ARGS))
(SETQ ARGS (CDR ARGS))
(SETQ ARGNO (SUB1 ARGNO))
(GO LOOP)))
(DFUNC (LOC X) (ILOC1 X NIL))
(DFUNC (MARKVAL LOCATION)
(PROG (VAR GVAL)
(COND ((NULL LOCATION) (COMPERR NULLLOC-MARKVAL)))
(SETQ GVAL (GENVAL))
(SETQ VAR (CAR (SETSLOT LOCATION (LIST GVAL))))
(SETQ LDLST (CONS VAR LDLST))
(RETURN VAR)))
(DFUNC (NONSPECVARS VRS)
(PROG (ANS)
LOOP (COND ((NULL VRS) (RETURN ANS))
((SPECVARP (CAR VRS)))
(T (SETQ ANS (CONS (CAR VRS) ANS))))
(SETQ VRS (CDR VRS))
(GO LOOP)))
(DFUNC (OUT1 OP AC AD) (OUTINST (TRANSOUT OP AC AD)))
(DFUNC (OUTCALL NUM FUN) (OUTFUNCALL (Q CALL) NUM FUN))
(DFUNC (OUTCALLF AC AD) (OUT1 (Q CALLF@) AC AD))
(DFUNC (OUTCJMP FLAG AC ADRESS)
(OUTJMP (COND (FLAG (Q JUMPN)) (T (Q JUMPE))) AC ADRESS))
(DFUNC (OUTENDTAG X)
(COND ((USEDTAGP X) (CLEARITALL) (RST X) (OUTTAG X))))
(DFUNC (OUTFUNCALL TYPE NUM FUN)
(OUTINST (LIST TYPE NUM (LIST (Q E) FUN))))
(DFUNC (OUTGOTAB X)
(PROG (ETAG)
(SETQ ETAG (GENTAG))
(PUTPROP ETAG (TOPCOPY PDL) (Q LEVEL))
(COND ((NOT (EQ (CAAR LASTOUT) (Q JRST))) (OUTJRST ETAG)))
(OUTTAG (CAR X))
LOOP (SETQ X (CDR X))
(COND ((NULL X) (OUTINST (Q (PUSHJ P *UDT)))
(OUTTAG ETAG)
(RETURN NIL)))
(OUTINST (LIST (Q CAIN) GOTABAC (LIST (Q QUOTE) (CAAR X))))
(OUTJRST (CDAR X))
(GO LOOP)))
(DFUNC (OUTJCALL NUM FUN) (OUTFUNCALL (Q JCALL) NUM FUN))
(DFUNC (OUTJMP OP AC ADR)
(PROG NIL
(SAVEACS)
(CLEAR1BOTH)
(RST ADR)
(PUTPROP ADR T (Q USED))
(OUTINST (LIST OP AC ADR))))
(DFUNC (OUTJRST ADR) (OUTJMP (Q JRST) 0 ADR))
(DFUNC (OUTMOVE AC MEM) (OUT1 (Q MOVE) AC MEM))
(DFUNC (OUTMOVEM AC MEM) (OUT1 (Q MOVEM) AC MEM))
(DFUNC (OUTPOP L) (PROG2 (SLOTPOP) (OUT1 (Q POP) (Q P) L)))
(DFUNC (OUTPUSH L) (OUT1 (Q PUSH) (Q P) L))
(DFUNC (OUTPUTSTAT ST)
(PROG (ADD)
(COND ((ATOM ST) (GO PRINT)))
(COND ((EQ (CAR ST) (Q LAP)) (GO PRINT)))
(SETQ CODESIZE (ADD1 CODESIZE))
(SETQ ADD (CADDR ST))
(COND ((AND (NOT (ATOM ADD)) (EQ (CAR ADD) (Q C)))
(SETQ CONSTSIZE (ADD1 CONSTSIZE))))
PRINT(PRINTSTAT ST)))
(DFUNC (OUTSPECPUSH VAR)
(PROG2 (SLOTPUSH (CONS VAR P2CNT))
(OUTPUSH (LIST (Q SPECIAL) VAR))))
(DFUNC (OUTSTAT ST)
(PROG NIL
(COND ((NULL LASTOUT) (GO SETIT)))
(OUTPUTSTAT (CAR LASTOUT))
(MAPC (FUNCTION PRINTEXPR) (CDR LASTOUT))
SETIT(SETQ LASTOUT (CONS ST (LAPNOTES)))
(RETURN NIL)))
(DFUNC (P2*EVAL XPR VALAC EFFECTS)
(PROG (ARG TEM)
(SETQ ARG (CADR XPR))
(COND ((AND (EQ (CAR ARG) (Q CONS))
(EQ (CAADR ARG) (Q QUOTE))
(GETL (SETQ TEM (CADADR ARG))
(Q (FEXPR FSUBR *FSUBR))))
(GO NOCONS)))
(RETURN (CALLSUBR XPR VALAC EFFECTS))
NOCONS
(LOADCOMP (CADDR ARG) VALUEAC)
(PROTECTACS TEM)
(OUTINST (LIST (Q CALL) 17 (LIST (Q E) TEM)))
(RETURN (MARKVAL VALUEAC))))
(DFUNC (P2ARG XPR VALAC EFFECTS)
(PROG (ARG)
(SETQ ARG (COMP (CADR XPR) VALAC))
(COND ((EQ (CAR ARG) (Q QUOTE))
(CPUSH VALAC)
(OUTMOVE VALAC (MINUS (ADD1 (PDLDEPTH))))
(REMOVE ARG)
(OUTINST (LIST (Q HRRZ) VALAC (CADR ARG) VALAC))
(RETURN (MARKVAL VALAC))))
(LOADARG VALAC ARG)
(OUT1 (Q ADD) VALAC (MINUS (ADD1 (PDLDEPTH))))
(OUTINST (LIST (Q HRRZ) VALAC (MINUS INUM0) VALAC))
(RETURN (MARKVAL VALAC))))
(DFUNC (P2BOOL XPR VALAC EFFECTS)
(PROG (CTAG RSL G)
(CLEAR2BOTH)
(PUTPROP (SETQ G (GENTAG)) T (Q SET))
(BOOLEXPR XPR VALAC G T MINDEPTH)
(RETURN (BOOLVALUE VALAC EFFECTS G))))
(DFUNC (P2CARCDR XPR VALAC EFFECTS)
(PROG (TEM)
(COND ((NOT (EQ (LENGTH (CDR XPR)) 1))
(USERERR ARGNOERR-P2CARCDR)))
(COND (EFFECTS (RETURN (COMPE (CADR XPR) VALAC))))
(SETQ XPR (CONS (SETQ TEM (GENSYM))
(CONS (CAR XPR) (COMP (CADR XPR) VALAC))))
(SETQ CCLST (CONS XPR CCLST))
(SETQ TEM (LIST TEM))
(SETQ LDLST (CONS TEM LDLST))
(RETURN TEM)))
(DFUNC (P2COND XPR VALAC EFFECTS)
(PROG (CTAG RSL SETQVARS VARLOC)
(SETQ SETQVARS (CADR XPR))
LOOP (COND ((NULL SETQVARS) (GO CC2)))
(COND ((ASSOC (CAR SETQVARS) LDLST) (GO CC3)))
ELOOP(SETQ SETQVARS (CDR SETQVARS))
(GO LOOP)
CC2 (CLEAR1)
(P2COND1 (CDDR XPR) VALAC EFFECTS MINDEPTH)
(INCR P2CNT)
(INCR P2CNT)
(RETURN (COND (EFFECTS NIL) (T (MARKVAL VALAC))))
CC3 (SETQ VARLOC (LOC (CONS (CAR SETQVARS) P2CNT)))
(COND ((NOT (NUMBERP VARLOC)) (GO CC4)))
(COND ((NOT (DVP (SLOTCONT VARLOC)))
(SETSLOT VARLOC (CONS (CAR SETQVARS) P2CNT))
(GO LOOP)))
CC4 (SLOTPUSH (CONS (CAR SETQVARS) P2CNT))
(OUTPUSH VARLOC)
(GO ELOOP)))
(DFUNC (P2COND1 EXP VALAC EFFECTS MINDEPTH)
(PROG (CONDEXIT PAIREXIT H1 H2 RETNIL IRSSL ACNIL PAIR ATAG REST AC)
(SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
(SETQ CONDEXIT (GENTAG))
(SETQ IRSSL (TOPCOPY PDL))
(SETQ MINDEPTH (PDLDEPTH))
(PUTPROP CONDEXIT IRSSL (Q LEVEL))
LOOP (SETQ RSL NIL)
(COND ((NULL EXP) (COND (RETNIL (LOADARG AC (Q (QUOTE NIL)))))
(OUTENDTAG CONDEXIT)
(COND ((USEDTAGP PAIREXIT) (CLEARITALL)))
(RESTORE IRSSL)
(RETURN NIL)))
(SETQ PAIR (CAR EXP))
(COND ((NULL (CDR PAIR))
(LOADCOMP (CAR PAIR) AC)
(COND ((NOT (NULL (CDR EXP))) (OUTCJMP T AC CONDEXIT))
(T (RESTORE IRSSL)))
(GO NONIL)))
(COND ((AND (EQUAL (CDR PAIR) (Q ((QUOTE NIL))))
(EQ (CAAR PAIR) (Q NULL))
(OR (ATOM (CADAR PAIR))
(NOT (HASPROP (CAADAR PAIR) (Q BOOL)))))
(LOADCOMP (CADAR PAIR) AC)
(OUTCJMP NIL AC CONDEXIT)
(SETQ RETNIL T)
(GO ELOOP)))
(COND ((OR LDLST (NOT (NULL (CDDR PAIR)))) (GO L2)))
(COND ((AND (EQ (CAADR PAIR) (Q GO))
(ATOM (SETQ ATAG (CADADR PAIR))))
(BOOLEXPR (CAR PAIR) AC (EQUIVTAG ATAG) T MINDEPTH)
(GO NONIL)))
(COND ((EQUAL (CADR PAIR) (Q (RETURN (QUOTE NIL))))
(BOOLEXPR (CAR PAIR) AC EXITN T MINDEPTH)
(GO NONIL)))
L2 (SETQ PAIREXIT (SETQ CTAG (GENTAG)))
(PUTPROP PAIREXIT IRSSL (Q LEVEL))
(SETQ RSL NIL)
(BOOLEXPR (CAR PAIR) AC PAIREXIT NIL MINDEPTH)
(SETQ H2 (COND ((NOT (ATOM RSL)) RSL)
(T (LIST (TOPCOPY ACS)
(TOPCOPY PDL)
(PDLDEPTH)))))
(SETQ H1 (LIST (TOPCOPY SPLDLST) (TOPCOPY CCLST)))
(SETQ REST (CDR PAIR))
LP1 (COND ((NULL (CDR REST)) (GO L1)))
(COMPE (CAR REST) AC)
(SETQ REST (CDR REST))
(GO LP1)
L1 (COND (EFFECTS (COMPE (CAR REST) AC))
(T (LOADCOMP (CAR REST) AC)))
(SAVEACS)
(SETQ SPLDLST (CAR H1))
(SETQ CCLST (CADR H1))
(SETQ H1 ACS)
(SETQ ACS (CAR H2))
(SETQ ACNIL (EQUAL (SLOTCONT AC) (Q (QUOTE NIL))))
(SETQ ACS H1)
(SETQ RETNIL NIL)
(COND ((NOT (MEMQ (CAAR REST) (Q (GO RETURN))))
(COND ((OR (NOT (NULL (CDR EXP)))
(AND (NOT EFFECTS)
(NOT ACNIL)
(SETQ RETNIL (USEDTAGP PAIREXIT))))
(OUTJRST CONDEXIT))
(T (RESTORE IRSSL)))))
(SETQ ACS (CAR H2))
(SETQ PDL (CADR H2))
(SETQ PDLDEPTH (CADDR H2))
(OUTTAG PAIREXIT)
(GO ELOOP)
NONIL(SETQ RETNIL NIL)
ELOOP(SETQ EXP (CDR EXP))
(GO LOOP)))
(DFUNC (P2ELSE XPR VALAC EFFECTS) (COMPERR SOMETHINGELSE-P2ELSE))
(DFUNC (P2EQ XPR VALAC EFFECTS)
(PROG NIL
(COND (EFFECTS (COMPE (CADR XPR) VALAC)
(COMPE (CADDR XPR) VALAC)
(RETURN NIL)))
(BOOLEQ1 (CDR XPR) VALAC NIL NIL)
(RETURN (BOOLVALUE VALAC EFFECTS NIL))))
(DFUNC (P2GO XPR VALAC EFFECTS)
(PROG (TAG)
(SETQ TAG (CADR XPR))
(SAVEACS)
(CLRPVARS)
(COND ((ATOM TAG) (OUTJRST (EQUIVTAG TAG)))
(T (LOADARG GOTABAC (COMP TAG VALAC)) (OUTJRST VGO)))
(RETURN (MARKVAL VALUEAC))))
(DFUNC (P2PROG XPR VALAC EFFECTS)
(PROG (PSFLG)
(SETQ PSFLG (PROGBIND (CADDR XPR)))
(SETQ PRGSPFLG NIL)
(CLEAR1)
(P2PROG1 XPR VALAC EFFECTS MINDEPTH)
(COND (PSFLG (OUTINST (Q (PUSHJ P SPECSTR)))))
(RETURN (MARKVAL VALAC))))
(DFUNC (P2PROG1 XPR VALAC EFFECTS MINDEPTH)
(PROG (GOLIST EXIT EXITN PVR PRSSL PROGSW VGO)
(INCR P2CNT)
(SETQ PROGSW T)
(SETQ PVR VALAC)
(SETQ EXIT (GENTAG))
(SETQ EXITN (GENTAG))
(SETQ VGO (GENTAG))
(SETQ GOLIST (CONS (CONS NIL EXIT)
(CONS (CONS NIL EXITN)
(CONS (CONS NIL VGO) (CADR XPR)))))
(SETQ PROGVARS (NONSPECVARS (CADDR XPR)))
(SETQ XPR (CDDDR XPR))
LOOP (COND ((NULL XPR) (GO EXITN)))
(INCR P2CNT)
(COND ((NOT PROGSW) (RESTORE PRSSL)))
(COND ((TAGP (CAR XPR)) (PROGTAG (CAR XPR)))
((AND (NULL (CDR XPR)) (EQ (CAAR XPR) (Q RETURN)))
(COND ((EQUAL (CDAR XPR) (Q ((QUOTE NIL)))) (GO EXITN))
(T (LOADARG PVR (COMP (CADAR XPR) VALAC))
(COND ((USEDTAGP EXITN) (OUTJRST EXIT)
(GO EXITN))
(T (GO EXIT))))))
(T (COMPE (CAR XPR) VALAC)))
(SETQ XPR (CDR XPR))
(GO LOOP)
EXITN(OUTENDTAG EXITN)
(COND ((NOT (EQ (CAAR LASTOUT) (Q JRST)))
(LOADARG PVR (Q (QUOTE NIL)))))
EXIT (OUTENDTAG EXIT)
(INCR P2CNT)
(INCR P2CNT)
(COND ((USEDTAGP VGO) (OUTGOTAB (CONS VGO (CDDDR GOLIST)))))
(RETURN NIL)))
(DFUNC (P2PROG2 XPR VALAC EFFECTS)
(PROG (ARGS ARG2)
(SETQ ARGS (CDR XPR))
(COND ((LESSP (LENGTH ARGS) 2) (USERERR TOFEWARGS-P2PROG2)))
(COMPE (CAR ARGS) VALAC)
(SETQ ARG2 (COND ((NOT EFFECTS) (COMP (CADR ARGS) VALAC))
(T (COMPE (CADR ARGS) VALAC))))
(SETQ ARGS (CDDR ARGS))
LOOP (COND ((NULL ARGS) (RETURN ARG2)))
(COMPE (CAR ARGS) VALAC)
(SETQ ARGS (CDR ARGS))
(GO LOOP)))
(DFUNC (P2QUOTE XPR VALAC EFFECTS) XPR)
(DFUNC (P2RETURN XPR VALAC EFFECTS)
(PROG (VAL)
(SETQ VAL (CADR XPR))
(SAVEACS)
(CLRPVARS)
(COND ((EQUAL VAL (Q (QUOTE NIL))) (OUTJRST EXITN))
(T (LOADARG PVR (COMP VAL VALAC)) (OUTJRST EXIT)))
(RETURN (COND (EFFECTS NIL) (T (MARKVAL VALAC))))))
(DFUNC (P2RPLAC XPR VALAC EFFECTS)
(PROG (ARG1 ARG2)
(SETQ ARG1 (COMP (CADR XPR) (FREEAC)))
(SETQ ARG2 (COMP (CADDR XPR) (FREEAC)))
(ILOC1 ARG1 VALAC)
(LOC ARG2)
(REMOVS ARG1)
(REMOVS ARG2)
(CLEAR2BOTH)
(COND ((EQUAL ARG2 (Q (QUOTE NIL)))
(OUT1 (CADR (ASSOC (CAR XPR)
(Q ((RPLACA HRRZS@)
(RPLACD HLLZS@)))))
0
(LOC ARG1)))
(T (OUT1 (CADR (ASSOC (CAR XPR)
(Q ((RPLACA HRLM@)
(RPLACD HRRM@)))))
(PUTINAC ARG2 (FREEAC))
(LOC ARG1))))
(REMOVE ARG2)
(RETURN ARG1)))
(DFUNC (P2SETARG XPR VALAC EFFECTS)
(PROG (TEM)
(LOC (SETQ TEM (COMP (CADDR XPR) VALAC)))
(COND ((EQ (CAADR XPR) (Q QUOTE))
(OUT1 (Q MOVE) 2 (MINUS (ADD1 (PDLDEPTH))))
(RETURN (OUTINST (LIST (Q HRRM)
(PUTINAC TEM VALAC)
(CADADR XPR)
2)))))
(LOADCOMP (CADR XPR) 2)
(CLEARACS)
(OUT1 (Q ADD) 2 (MINUS (ADD1 (PDLDEPTH))))
(OUTINST (LIST (Q HRRM)
(PUTINAC TEM VALAC)
(MINUS INUM0)
2))))
(DFUNC (P2SETQ XPR VALAC EFFECTS)
(PROG (NVAR VALLOC HOME VAR VAL TEM AC)
(SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
(SETQ VAR (CAR (CDR XPR)))
(SETQ VAL (COMP (CADR (CDR XPR)) AC))
(ILOC1 VAL AC)
(COND ((ASSOC VAR SPLDLST) (OUTSPECPUSH VAR) (REMSPVAR VAR)))
(REMOVE VAL)
(FREEZE VAR)
(SETQ VALLOC (LOC VAL))
(SETQ HOME (COND ((SPECVARP VAR) T)
((NOT (ILOC (SETQ NVAR (CONS VAR P2CNT)) AC))
NIL)
(T (NOT (DVP (SLOTCONT (LOC NVAR)))))))
(INCR P2CNT)
(COND ((AND EFFECTS (NOT HOME))
(COND ((AND (NUMBERP VALLOC)
(NOT (DVP (SLOTCONT VALLOC))))
(SETSLOT VALLOC (LIST VAR))
(GO EXIT))
(T (SLOTPUSH (LIST VAR))
(OUTPUSH VALLOC)
(GO EXIT)))))
(COND ((AND HOME (EQUAL VAL (Q (QUOTE NIL))))
(SETQ TEM T)
(OUT1 (COND ((OR EFFECTS (DVP (SLOTCONT AC)))
(SETQ TEM NIL)
(Q CLEARM))
(T (Q CLEARB)))
AC
(SETQ VAL (COND ((SPECVARP VAR)
(LIST (Q SPECIAL) VAR))
(T (ILOC (CONS VAR (SUB1 P2CNT))
AC)))))
(COND ((NUMBERP VAL) (SETSLOT VAL (LIST VAR))))
(COND (TEM (SETSLOT AC
(CONS VAR
(COND ((NUMBERP VAL) (Q DUP))
(T NIL))))))
(GO EXIT)))
(COND ((OR (NOT (NUMBERP VALLOC))
(LESSP VALLOC 0)
(DVP (SLOTCONT VALLOC)))
(LOADARG AC VAL)
(SETQ VALLOC AC)))
(SETSLOT VALLOC (LIST VAR))
(COND ((SPECVARP VAR)
(COND ((ZEROP VALLOC) (OUTPOP (LIST (Q SPECIAL) VAR)))
(T (OUTMOVEM VALLOC (LIST (Q SPECIAL) VAR))))))
EXIT (RETURN (COMP VAR AC))))
(DFUNC (P2STORE XPR VALAC EFFECTS)
(PROG (TEM)
(LOC (SETQ TEM (COMP (CADDR XPR) VALAC)))
(COMPE (CADR XPR) VALAC)
(LOADARG ARRAYAC TEM)
(OUTINST (Q (PUSHJ P NSTR)))
(RETURN TEM)))
(DFUNC (PASS2 X)
(PROG (ACS PDL PDLDEPTH MINDEPTH LDLST SPLDLST SPECFLAG PRGSPFLG
CCLST VARLIST PROGVARS PROGSW GOLIST)
(SETQ P2CNT 1)
(SETQ ACS (LISTNILS NACS))
(SETQ ALLACS (SUB1 (LSH 1 NACS)))
(SETQ PDL NIL)
(SETQ PDLDEPTH (LENGTH PDL))
(SETQ MINDEPTH (PDLDEPTH))
(SETQ SPECFLAG (LAMBDABIND (CADR X)))
(COND ((NOT (EQ (CAADDR X) (Q PROG))) (SETQ PRGSPFLG NIL)))
(LOADCOMP (CADDR X) VALUEAC)
(EXITBUM SPECFLAG)
(OUTINST (OUTINST NIL))
(COND (LDLST (COMPERR LDLSTLEFT-PASS2)))
(RETURN NIL)))
(DFUNC (PROGBIND VARS) (BINDVARS VARS NIL))
(DFUNC (PROGTAG TAG)
(PROG NIL
(CLEAR2BOTH)
(CLEARACS)
(CLRPVARS)
(RESTORE PRSSL)
(OUTTAG (EQUIVTAG TAG))))
(DFUNC (PROTECTACS X)
(PROG (WHICHACS ACNO)
(SETQ WHICHACS (ACEFFECTS X))
(SETQ ACNO 0)
LOOP (SETQ ACNO (ADD1 ACNO))
(COND ((ZEROP WHICHACS) (RETURN NIL))
((NOT (ZEROP (BOOLE 1 1 WHICHACS))) (CLEARAC ACNO)))
(SETQ WHICHACS (LSH WHICHACS -1))
(GO LOOP)))
(DFUNC (PUTINAC X AC)
(PROG (Z)
(SETQ Z (LOC X))
(COND ((NOT (ACNUMP Z)) (LOADARG (SETQ Z AC) X)))
(REMOVE X)
(CPUSH Z)
(RETURN Z)))
(DFUNC (REMOVE DATA)
(PROG NIL (REMLST DATA (Q LDLST)) (REMLST DATA (Q SPLDLST))))
(DFUNC (REMLST DATA LST)
(PROG (TEM)
(SETQ TEM (GETPROP LST (Q VALUE)))
LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
(COND ((EQUAL (CADR TEM) DATA) (RPLACD TEM (CDDR TEM)))
(T (SETQ TEM (CDR TEM))))
(GO LOOP)))
(DFUNC (REMOVS DATA) (REMLST DATA (Q SPLDLST)))
(DFUNC (REMSPVAR SPV)
(PROG (SPL)
(SETQ SPL (GETPROP (Q SPLDLST) (Q VALUE)))
BACK (COND ((NULL (CDR SPL)) (RETURN NIL)))
(COND ((EQ SPV (CAADR SPL)) (RPLACD SPL (CDDR SPL)))
(T (SETQ SPL (CDR SPL))))
(GO BACK)))
(DFUNC (RESTORE OLDPDL)
(PROG (C V R TEM OLDDEPTH DEPTHDIF)
(SETQ OLDDEPTH (LENGTH OLDPDL))
(COND ((GREATERP OLDDEPTH (PDLDEPTH))
(PRINTMSG (LIST OLDPDL PDL))
(COMPERR PDLSHORT-RESTORE)))
A1 (SETQ C 0)
A (COND ((EQUAL OLDDEPTH (PDLDEPTH)) (RETURN (SHRINKPDL C)))
((DVP (SETQ R (CAR PDL))) (GO CPP)))
(SETQ C (ADD1 C))
(SLOTPOP)
(GO A)
CPP (SHRINKPDL C)
CPP1 (SETQ V OLDPDL)
(SETQ C 0)
(SETQ DEPTHDIF (*DIF (PDLDEPTH) OLDDEPTH))
CPP3 (COND ((NULL V) (SETQ V (FINDFREEAC))
(COND ((NULL V) (COMPERR NOAC-RESTORE)))
(SETSLOT V R)
(OUTPOP V)
(GO A1))
((AND (CAR V)
(EQ (CAAR V) (CAR R))
(NOT (DVP (SLOTCONT (SETQ TEM
(MINUS (PLUS C
DEPTHDIF)))))))
(GO CPP2)))
(SETQ C (ADD1 C))
(SETQ V (CDR V))
(GO CPP3)
CPP2 (SETSLOT TEM R)
(OUTPOP TEM)
(GO A1)))
(DFUNC (RSLSET X)
(COND ((EQ X CTAG)
(SETQ RSL (COND ((AND RSL
(NOT (AND (EQUAL (CAR RSL) ACS)
(EQUAL (CADR RSL) PDL))))
(Q LOSE))
(T (LIST (TOPCOPY ACS)
(TOPCOPY PDL)
(PDLDEPTH))))))))
(DFUNC (RST TAG)
(COND ((NULL TAG) NIL)
((ASSOCR TAG GOLIST) (RESTORE PRSSL))
((REMPROP TAG (Q SET)) (SAVEACS)
(PUTPROP TAG (TOPCOPY PDL) (Q LEVEL))
(SETQ MINDEPTH (PDLDEPTH)))
((SETQ TAG (SEEKPROP TAG (Q LEVEL))) (RESTORE (PROPVAL TAG)))
(T (COMPERR NIL-RST))))
(DFUNC (SAVEACS)
(PROG (K)
(SETQ K 0)
LOOP (COND ((EQ K NACS) (RETURN NIL)))
(CPUSH (SETQ K (ADD1 K)))
(GO LOOP)))
(DFUNC (SETSLOT X Y) (RPLACA (GETSLOT X) Y))
(DFUNC (SHRINKPDL C)
(COND ((NOT (ZEROP C))
(OUTINST (LIST (Q SUB) (Q P) (GENCONST 0 0 C C 0))))))
(DFUNC (SIDEEFFECTS FUN) (NOT (HASPROP FUN (Q ACS))))
(DFUNC (SLOTCONT X) (CAR (GETSLOT X)))
(DFUNC (SLOTLIST) (APPEND ACS PDL))
(DFUNC (SLOTPOP)
(PROG NIL (SETQ PDLDEPTH (SUB1 PDLDEPTH)) (SETQ PDL (CDR PDL))))
(DFUNC (SLOTPUSH SC)
(PROG NIL (SETQ PDLDEPTH (ADD1 PDLDEPTH)) (SETQ PDL (CONS SC PDL))))
(DFUNC (SPECVARP VAR) (MEMBER VAR SPECVARS))
(DFUNC (TRANSOUT OP AC AD)
(PROG (TEM IND)
(COND ((OR (ATOM AD) (ATOM (CAR AD))) (GO DONE)))
(SETQ AD (CAR AD))
(COND ((SETQ TEM (SEEKPROP OP (Q IMMED)))
(SETQ OP (PROPVAL TEM))
(GO DONE)))
(SETQ AD (GENCONST 0 0 AD 0 0))
DONE (SETQ IND (COND ((OR (NOT (NUMBERP AD)) (GREATERP AD 0)) NIL)
(T (LIST (Q P)))))
(RETURN (MCONS OP AC AD IND))))
(DFUNC (USEDTAGP TAG) (HASPROP TAG (Q USED)))
(MAPDEF PASS2 (EXPR CALLSUBR) (SUBR CALLSUBR) (*SUBR CALLSUBR)
(*UNDEF CALLSUBR) (LSUBR CALLLSUBR) (*LSUBR CALLLSUBR)
(FEXPR CALLFSUBR) (FSUBR CALLFSUBR) (*FSUBR CALLFSUBR)
(FUNVAR CALLFUNARGS) (CARCDR P2CARCDR) (P2 DOP2))
(MAPDEF P2 (AND P2BOOL) (ARG P2ARG) (*EVAL P2*EVAL) (COND P2COND)
(EQ P2EQ) (GO P2GO) (NULL P2BOOL) (OR P2BOOL)
(QUOTE P2QUOTE) (PROG P2PROG) (PROG2 P2PROG2)
(RETURN P2RETURN) (RPLACA P2RPLAC) (RPLACD P2RPLAC)
(SETARG P2SETARG) (SETQ P2SETQ) (STORE P2STORE))
(MAPDEF BOOL (AND BOOLAND) (EQ BOOLEQ) (NULL BOOLNULL) (OR BOOLOR)
(QUOTE BOOLQUOTE))
(SETQ CARCDRDEPTH 4)
(PROG (BASE COUNT LIMIT MIDDLE NAME)
(SETQ BASE 2)
(SETQ LIMIT (SUB1 (LSH 1 (ADD1 CARCDRDEPTH))))
(SETQ COUNT (LSH 1 1))
LOOP (COND ((GREATERP COUNT LIMIT) (RETURN NIL)))
(SETQ MIDDLE (SUBST (QUOTE A)
0
(SUBST (QUOTE D) 1 (CDR (EXPLODE COUNT)))))
(SETQ NAME (READLIST (APPEND (QUOTE (C)) MIDDLE (QUOTE (R)))))
(PUTPROP NAME
(CONS (CAR MIDDLE)
(COND ((CDR MIDDLE)
(READLIST (APPEND (QUOTE (C))
(CDR MIDDLE)
(QUOTE (R)))))))
(QUOTE CARCDR))
(SETQ COUNT (ADD1 COUNT))
(GO LOOP))
(MAPDEF ACS (*APPEND 37) (ATOM 1) (CONS 3) (GENSYM 7) (GET 1)
(LAST 3) (LENGTH 7) (MEMBER 37) (NCONS 3) (XCONS 3))
(MAPDEF COMMU (CONS XCONS) (EQUAL EQUAL) (*GREAT *LESS)
(*LESS *GREAT) (*PLUS *PLUS) (*TIMES *TIMES))
(MAPDEF IMMED (CAME CAIE) (CAMN CAIN) (HLLZS@ HLLZS) (HLRZ@ HLRZ)
(HRLM@ HRLM) (HRRM@ HRRM) (HRRZ@ HRRZ) (HRRZS@ HRRZS)
(MOVE MOVEI))
(SETQ NACS 5)
(SETQ VALUEAC 1)
(SETQ FARGAC 1)
(SETQ GOTABAC 1)
(SETQ ARRAYAC 1)
(SETQ INUM0 (MAKNUM 0 (QUOTE FIXNUM)))
(ENDBLOCK PASS2)
(BEGINBLOCK DEBUG)
(DFUNC (CMPBREAK TYPE MESSAGE)
(PROG NIL
(INC NIL T)
(OUTC NIL T)
(COND ((ATMARGIN) (LINEF 1)) (T (LINEF 2)))
(PRINL (APPEND TYPE MESSAGE))
(LINEF 1)
LOOP (COND ((EQUAL (ERRSET (EVALREAD)) (Q (PROCEED)))
(RETURN (Q DONE))))
(GO LOOP)))
(DEFPROP COMPERR
(LAMBDA (L) (CMPBREAK (Q (*COMPILER ERROR*)) L))
FEXPR)
(DFUNC (EVALREAD)
(PROG (EX)
(LINEF 1)
(SETQ EX (READ))
(PRINC *SP)
(RETURN (PRINC (EVAL EX)))))
(DFUNC (LAPNOTES) (COPY (MAPCAR (FUNCTION EVAL) TRACELIST)))
(DEFPROP USERERR (LAMBDA (L) (CMPBREAK (Q (*USER ERROR*)) L)) FEXPR)
(SETQ TRACELIST NIL)
(ENDBLOCK DEBUG)
(BEGINBLOCK IO)
(DFUNC (ATMARGIN) (EQ (CHRCT) (LINELENGTH NIL)))
(DFUNC (CARRETN) (COND ((NOT (ATMARGIN)) (LINEF 1))))
(DFUNC (FORMF) (PROG NIL (PRINC *FF) (SETQ LINCNT PAGEHEIGHT)))
(DFUNC (LINEF N)
(PROG NIL
LOOP (COND ((ZEROP N) (RETURN NIL)))
(TERPRI)
(SETQ N (SUB1 N))
(GO LOOP)))
(DFUNC (PRINL L) (MAPC (FUNCTION PRINS) L))
(DFUNC (PRINS FN)
(PROG2 (COND ((GREATERP (ADD1 (FLATSIZE FN)) (CHRCT)) (LINEF 1)))
(PRINTEXPR FN)))
(DFUNC (PRINTEXPR XPR) (PROG2 (PRIN1 XPR) (PRINC *SP)))
(DFUNC (PRINTSTAT STAT)
(PROG NIL
(COND ((GREATERP (DIFFERENCE (LINELENGTH NIL) (CHRCT)) 7)
(LINEF 1)))
(COND ((NULL STAT) (GO WORD))
((ATOM STAT) (GO TAG))
((EQ (CAR STAT) (Q LAP)) (GO TAG)))
WORD (PRINC *TB)
(PRINTEXPR STAT)
(RETURN NIL)
TAG (CARRETN)
(PRINTEXPR STAT)
(RETURN NIL)))
(MAPCAR (FUNCTION (LAMBDA (PAIR)
(PROG2 (SET (CAR PAIR)
(INTERN (ASCII (CADR PAIR))))
(CAR PAIR))))
(QUOTE ((*SP 40) (*TB 11)
(*CR 15)
(*LF 12)
(*VT 13)
(*FF 14)
(*CO 54)
(*PT 56)
(*LP 50)
(*RP 51)
(*SL 57)
(*AM 33)
(*AT 100)
(*RO 177)
(*COLON 72))))
(SETQ LINCNT 0)
(SETQ PAGEHEIGHT 74)
(SETQ PAGEWIDTH 120)
(ENDBLOCK IO)
(BEGINBLOCK GENERAL)
(DFUNC (ADDTOLIST X Y) (COND ((MEMBER X Y) Y) (T (CONS X Y))))
(DFUNC (ASSOCR X Y)
(PROG NIL
LOOP (COND ((NULL Y) (RETURN NIL))
((EQ X (CDAR Y)) (RETURN (CAR Y))))
(SETQ Y (CDR Y))
(GO LOOP)))
(DFUNC (CONSTANTP XPR) (OR (NUMBERP XPR) (MEMBER XPR (Q (T NIL)))))
(DFUNC (COPY EX) (SUBST 0 0 EX))
(DFUNC (DEINITSYM NAME) (DELETEPROP NAME (Q SYMNO)))
(DFUNC (FSUBRP FUN) (GETL FUN (Q (FEXPR *FSUBR FSUBR))))
(DFUNC (GETGET ATOM PROP)
(PROG (TEM PTAB)
(SETQ PTAB (FIRSTPROP ATOM))
LOOP (COND ((LASTPROP PTAB) (RETURN NIL)))
(COND ((SETQ TEM (SEEKPROP (PROPNAM PTAB) PROP))
(RETURN TEM)))
(SETQ PTAB (NEXTPROP PTAB))
(GO LOOP)))
(DFUNC (INITSYM NAME) (INITPROP NAME (Q SYMNO) 1))
(DFUNC (LSUBRP FUN) (GETL FUN (Q (LSUBR *LSUBR))))
(DFUNC (MAKESPECIAL VAR)
(PROG NIL
(COND ((HASPROP VAR (Q LOCAL))
(PRINTMSG (CONS VAR (Q (LOCAL AND SPECIAL))))))
(SETPROP VAR (Q SPECIAL) T)
(RETURN VAR)))
(DFUNC (MAKESYM IDENT NUMBER)
(PROG (*NOPOINT)
(SETQ *NOPOINT T)
(RETURN (MAKNAM (APPEND (EXPLODE IDENT) (EXPLODE NUMBER))))))
(DFUNC (MAKEUNSPECIAL VAR) (COND ((REMPROP VAR (Q SPECIAL)) VAR)))
(DFUNC (NEXTSYM NAME)
(PROG (NUM)
(SETQ NUM (GETPROP NAME (Q SYMNO)))
(PUTPROP NAME (ADD1 NUM) (Q SYMNO))
(RETURN (MAKESYM NAME NUM))))
(DFUNC (NTHCDR NUM EXP)
(PROG NIL
(COND ((MINUSP NUM) (COMPERR NEGNUM-NTHCDR)))
LOOP (COND ((ZEROP NUM) (RETURN EXP)))
(COND ((ATOM EXP) (COMPERR ATOM-NTHCDR)))
(SETQ EXP (CDR EXP))
(SETQ NUM (SUB1 NUM))
(GO LOOP)))
(DFUNC (SUBRP FUN) (GETL FUN (Q (EXPR SUBR ARRAY *SUBR *UNDEF))))
(DFUNC (TOPCOPY SXP) (APPEND SXP NIL))
(BEGINBLOCK PROPTABLE)
(DFUNC (DELETEPROP IDENT PROPNAM)
(PROG (TEM)
(SETQ TEM IDENT)
LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
(COND ((EQ (CADR TEM) PROPNAM) (RPLACD TEM (CDDDR TEM))
(RETURN T)))
(SETQ TEM (CDDR TEM))
(GO LOOP)))
(DFUNC (HASPROP IDENT PROP) (GETL IDENT (LIST PROP)))
(DFUNC (INITPROP IDENT PROPNAM PROPVAL)
(RPLACD IDENT (MCONS PROPNAM PROPVAL (CDR IDENT))))
(DFUNC (SEEKPROP IDENT PROPNAM)
(PROG (TEM)
(SETQ TEM (GETL IDENT (LIST PROPNAM)))
(COND ((NULL TEM) (RETURN NIL)))
(RETURN TEM)))
(DFUNC (SETPROP IDENT PROPNAM PROPVAL)
(PUTPROP IDENT PROPVAL PROPNAM))
(ENDBLOCK PROPTABLE)
(ENDBLOCK GENERAL)
(ENDBLOCK COMPILER)